packages feed

ajhc (empty) → 0.8.0.1

raw patch · 390 files changed

+65094/−0 lines, 390 filesdep +HsSyckdep +Win32dep +arraybuild-type:Customsetup-changed

Dependencies added: HsSyck, Win32, array, base, binary, bytestring, containers, directory, fgl, filepath, haskeline, mtl, old-time, pretty, process, random, regex-compat, syb, temporary, unix, utf8-string, zlib

Files

+ COPYING view
@@ -0,0 +1,350 @@+All or most of the source files in this distribution refer to this+file for copyright and warranty information.  This file should be+included whenever those files are redistributed.++This software is free software: you can redistribute it and/or modify+it under the terms of the GNU General Public License, version 2, as+published by the Free Software Foundation or any later version at your option.+That license is reproduced below.+++		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 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.++			    Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, 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 or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+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 give any other recipients of the Program a copy of this License+along with the Program.++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 Program or any portion+of it, thus forming a work based on the Program, 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) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+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 Program, 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 Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) 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; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, 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 executable.  However, as a+special exception, the source code 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.++If distribution of executable or 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 counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program 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.++  5. 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 Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program 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 to+this License.++  7. 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 Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program 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 Program.++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.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program 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.++  9. The Free Software Foundation may publish revised and/or new versions+of the 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 Program+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 Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, 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++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), 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 Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year  name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ Makefile.cabalinst view
@@ -0,0 +1,19 @@+INSTALL=install+INSTALL_DATA=$(INSTALL) -m 644+LIB_OPTIONS=$(RTSOPTS) $(JHC_TEST)  -L- -L.+include library_deps.make++## Note: Should write like below style for Windows + msys env.+##      install FILES "DESTDIR"+install: $(JHC_LIBS) $(JHC_EXT_LIBS)+	$(INSTALL) -d "$(TARGET)/include"+	$(INSTALL) -d "$(TARGET)/lib"+	$(INSTALL) -d "$(TARGET)/etc"+	for lib in $(JHC_LIBS) $(JHC_EXT_LIBS); do \+		test -f "$$lib" && $(INSTALL_DATA) $$lib "$(TARGET)/lib" ; \+	done+	$(INSTALL_DATA) ./rts/HsFFI.h "$(TARGET)/include"+	$(INSTALL_DATA) ./src/data/targets.ini "$(TARGET)/etc"+	cd "$(BINDIR)" && ln -sf ajhc$(EXEEXT) ajhci$(EXEEXT)++.PHONY: install
+ README.md view
@@ -0,0 +1,101 @@+# [Ajhc](http://ajhc.github.com/) - arafura-jhc [![Build Status](https://travis-ci.org/ajhc/ajhc.png)](https://travis-ci.org/ajhc/ajhc)++A fork of [jhc](http://repetae.net/computer/jhc/).+And also Haskell compiler. ++This project is founded by [Metasepi Project](http://metasepi.masterq.net/).++## How to install++    $ cabal install ajhc++## How to build latest version++    $ sudo apt-get install make locales autoconf libreadline-dev \+      libwww-perl libconfig-yaml-perl graphviz haskell-platform drift pandoc \+      libghc-readline-dev libghc-utf8-string-dev libghc-hssyck-dev+    $ git clone git://github.com/ajhc/ajhc.git+    $ cd ajhc+    $ git checkout arafura+    $ autoreconf -i+    $ ./configure+    $ make cabal-install++## For developing++First, you should use the arafura branch, rather than master branch.++* [master branch](https://github.com/ajhc/ajhc/tree/master): Do not touch me, mirror of [jhc's darcs repository](http://repetae.net/dw/darcsweb.cgi?r=jhc).+* [arafura branch](https://github.com/ajhc/ajhc/tree/arafura): For developing Ajhc.++You should send patch to jhc, if testing on Ajhc is good.++    $ darcs get http://repetae.net/repos/jhc+    $ cd jhc/+    $ patch -p1 < ~/yourfile.patch+    $ darcs record -a+    $ darcs send++The command [darcs send](http://darcs.net/Using/Send) sends email the patch to+jhc author (= [John Meacham](http://repetae.net/)).++## Needing to install/build on Windows (currently in progress)++### Install msys++http://sourceforge.net/projects/mingw/files/Installer/mingw-get-inst/++Install below.++* C Compiler+* MSYS Basic System+* MinGW Developer ToolKit++You should run cabal install on msys console.++### Install Git for Windows++http://msysgit.github.com/++It's good choosing the below option.++* "Checkout as-is, commit as-is"+* "Run Git and included Unix tools from the Windows Command Prompt"++### Install Haskell Platform++http://www.haskell.org/platform/windows.html++### Install DrIFT++    $ cabal install DrIFT-cabalized++## Future plan++### Done++* Try to rewrite a part of NetBSD bootloader.+  http://www.youtube.com/watch?v=JMyxy5Qo2m8+* Translate Jhc User’s Manual to Japanese.+  http://metasepi.masterq.net/posts/2013-01-12-jhc_manual_ja.html+* Fix bug that run stm32f3-discovery demo. It causes Ajhc RTS heep impl.+  https://github.com/ajhc/demo-cortex-m3/tree/master/stm32f3-discovery+* Support to build on Windows.+* Cabalize Ajhc. Ajhc's hl files will be not controled with cabal.++### Yet++* No more depend on DrIFT. Use http://hackage.haskell.org/package/derive.+* No more depend on Perl (LWP and YAML).+* Support LPCXpresso NXP LPX1769 with demo.+* Rewrite Cortex-M3 base library with Ajhc.+* Pass all regress test, and enable regress fail setting on travis-ci.+  https://travis-ci.org/ajhc/ajhc+* Analyze jhc internal (Japanese doc).+  http://metasepi.masterq.net/posts/2013-01-31-jhc_internal_overview.html+* Find critical region of Ajhc for reentrant and thread safe.+* Port Haskell libraries on haskell-platform to Ajhc.+* Understand jhc's region inference.+* Find the method to implement GC that can be interrupted.+* Get smaller RTS. Benchmark the RTS for running on custom FPGA CPU.+* Start rewritng NetBSD kernel with Ajhc.
+ Setup.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+import Distribution.Simple+import Distribution.Simple.InstallDirs as I+import Distribution.Simple.LocalBuildInfo as L+import qualified Distribution.Simple.Setup as S+import qualified Distribution.Simple.Program as P+import System.FilePath ((</>), splitDirectories)+import qualified System.FilePath.Posix as Px+import Distribution.Package++make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make"++#ifdef mingw32_HOST_OS+(<//>) = (Px.</>)+jhcCmd local = Px.joinPath $ splitDirectories $+               buildDir local <//> pName <//> pName+#else+jhcCmd local = buildDir local </>  pName </>  pName+#endif+  where pName = "ajhc"++installStdLib pkg local verbosity copy+    = do let dirs = L.absoluteInstallDirs pkg local copy+             idir = datadir dirs+             bdir = bindir dirs+             icmd = jhcCmd local+#ifdef mingw32_HOST_OS+             exeExt = ".exe"+#else+             exeExt = ""+#endif+         putStrLn $ "Installing libraries in " ++ idir+         make verbosity+               [ "-f", "Makefile.cabalinst", "install"+               , "TARGET=" ++ idir+               , "JHCPROG=" ++ icmd+               , "BINDIR=" ++ bdir+               , "EXEEXT=" ++ exeExt+               ]++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {+  postInst = \ _ flags pkg lbi -> do+     let verb = (S.fromFlag $ S.installVerbosity flags)+     installStdLib pkg lbi verb NoCopyDest+  }
+ ajhc.cabal view
@@ -0,0 +1,271 @@+cabal-version: >= 1.6+name:          ajhc+build-type:    Custom+version:       0.8.0.1+license:       GPL-2+license-file:  COPYING+category:      Compiler+author:        John Meacham <john@repetae.net>+maintainer:    Kiwamu Okabe <kiwamu@debian.or.jp>+synopsis:      Haskell compiler that produce binary through C language+description:   The jhc is a haskell compiler which aims to produce the most efficient+               programs possible via whole program analysis and other optimizations.+               .+               The jhc is very minimalist in that it does not have a precompiled run time+               system, but rather generates what is needed as part of the compilation+               process. However, back ends do have specific run-time representations of+               data, which can be affected by things like the choice of garbage collector.+homepage:      http://ajhc.masterq.net/++data-files:    README.md++extra-source-files:+    examples/*.hs rts/HsFFI.h Makefile.cabalinst library_deps.make src/data/targets.ini+    src/StringTable/StringTable_cbits.h src/cbits/config.h src/hs_src_config.h+    utils/build_extlibs.prl+    lib/haskell-extras/Data/Bits.hs lib/haskell-extras/Data/Maybe.hs lib/haskell-extras/Data/Bits.m4 lib/haskell-extras/Data/IORef.hs lib/haskell-extras/Data/Monoid.hs lib/haskell-extras/Data/Int.hs lib/haskell-extras/Data/Typeable.hs lib/haskell-extras/Data/Functor.hs lib/haskell-extras/Data/Char.hs lib/haskell-extras/Data/Array/Unboxed.hs lib/haskell-extras/Data/Array/IO.hs lib/haskell-extras/Data/Complex.hs lib/haskell-extras/Data/Array.hs lib/haskell-extras/Data/Version.hs lib/haskell-extras/Data/Function.hs lib/haskell-extras/Data/List.hs lib/haskell-extras/Data/Unique.hs lib/haskell-extras/Data/Ix.hs lib/haskell-extras/Data/Dynamic.hs lib/haskell-extras/Data/Unicode.hs lib/haskell-extras/Data/Word.hs lib/haskell-extras/Prelude.hs lib/haskell-extras/haskell-extras.yaml.m4 lib/haskell-extras/Unsafe/Coerce.hs lib/haskell-extras/Foreign.hs lib/haskell-extras/Typeable.hs lib/haskell-extras/Debug/Trace.hs lib/haskell-extras/System/IO/Pipe.hs lib/haskell-extras/System/IO/Binary.hs lib/haskell-extras/System/IO/Error.hs lib/haskell-extras/System/IO/Continuation.hs lib/haskell-extras/System/Random.hs lib/haskell-extras/System/Exit.hs lib/haskell-extras/System/Console/GetOpt.hs lib/haskell-extras/System/Time.hs lib/haskell-extras/System/Directory.hs lib/haskell-extras/System/CPUTime.hs lib/haskell-extras/System/Cmd.hs lib/haskell-extras/System/Environment.hs lib/haskell-extras/System/Info.hs lib/haskell-extras/System/IO.hs lib/haskell-extras/System/Locale.hs lib/haskell-extras/Text/Show/Functions.hs lib/haskell-extras/Text/Printf.hs lib/haskell-extras/Control/Monad/Fix.hs lib/haskell-extras/Control/Monad/Instances.hs lib/haskell-extras/Control/Exception.hs lib/haskell-extras/Control/Monad.hs lib/haskell-extras/Foreign/C.hs lib/haskell-extras/Foreign/ForeignPtr.hs lib/haskell-extras/Foreign/StablePtr.hs lib/haskell-extras/Foreign/Marshal/Pool.hs lib/haskell-extras/Foreign/Marshal/Error.hs lib/haskell-extras/Foreign/Marshal.hs lib/haskell98/Maybe.hs lib/haskell98/Random.hs lib/haskell98/Time.hs lib/haskell98/prologue.txt lib/haskell98/System.hs lib/haskell98/Ratio.hs lib/haskell98/Directory.hs lib/haskell98/CPUTime.hs lib/haskell98/haskell98.yaml lib/haskell98/Char.hs lib/haskell98/Complex.hs lib/haskell98/Array.hs lib/haskell98/List.hs lib/haskell98/IO.hs lib/haskell98/Ix.hs lib/haskell98/Monad.hs lib/haskell98/Locale.hs lib/haskell98/LICENSE lib/flat-foreign/Bits.hs lib/flat-foreign/Ptr.hs lib/flat-foreign/MarshalAlloc.hs lib/flat-foreign/MarshalError.hs lib/flat-foreign/Storable.hs lib/flat-foreign/CForeign.hs lib/flat-foreign/ForeignPtr.hs lib/flat-foreign/Int.hs lib/flat-foreign/StablePtr.hs lib/flat-foreign/MarshalArray.hs lib/flat-foreign/flat-foreign.yaml lib/flat-foreign/MarshalUtils.hs lib/flat-foreign/CTypes.hs lib/flat-foreign/Word.hs lib/flat-foreign/CError.hs lib/flat-foreign/CString.hs lib/applicative/Data/Foldable.hs lib/applicative/Data/Traversable.hs lib/applicative/Control/Applicative.hs lib/applicative/Control/Arrow.hs lib/applicative/Control/Category.hs lib/applicative/applicative.yaml lib/jhc/Numeric.hs lib/jhc/Data/Ratio.hs lib/jhc/Jhc/Order.hs lib/jhc/Jhc/Numeric.hs lib/jhc/Jhc/Maybe.hs lib/jhc/Jhc/Inst/Order.hs lib/jhc/Jhc/Inst/Storable.hs lib/jhc/Jhc/Inst/Show.hs lib/jhc/Jhc/Inst/PrimEnum.hs lib/jhc/Jhc/Inst/Enum.hs lib/jhc/Jhc/Inst/Num.hs lib/jhc/Jhc/Inst/Read.hs lib/jhc/Jhc/Enum.m4 lib/jhc/Jhc/Hole.hs lib/jhc/Jhc/String.hs lib/jhc/Jhc/Prim.hs lib/jhc/Jhc/Options.hs lib/jhc/Jhc/Show.hs lib/jhc/Jhc/Handle.hs lib/jhc/Jhc/ForeignPtr.hs lib/jhc/Jhc/Type/C.hs lib/jhc/Jhc/Type/Ptr.hs lib/jhc/Jhc/Type/Basic.hs lib/jhc/Jhc/Type/Handle.hs lib/jhc/Jhc/Type/Float.hs lib/jhc/Jhc/Type/Word.hs lib/jhc/Jhc/ACIO.hs lib/jhc/Jhc/JumpPoint.hs lib/jhc/Jhc/Int.hs lib/jhc/Jhc/Class/Real.hs lib/jhc/Jhc/Class/Ord.hs lib/jhc/Jhc/Class/Num.hs lib/jhc/Jhc/Float.hs lib/jhc/Jhc/Text/Read.hs lib/jhc/Jhc/Num.m4 lib/jhc/Jhc/List.hs lib/jhc/Jhc/Enum.hs lib/jhc/Jhc/IO.hs lib/jhc/Jhc/Order.m4 lib/jhc/Jhc/Monad.hs lib/jhc/Jhc/Addr.hs lib/jhc/Jhc/Basics.hs lib/jhc/Jhc/Num.hs lib/jhc/Jhc/Tuples.hs lib/jhc/System/IO/Unsafe.hs lib/jhc/System/Mem/StableName.hs lib/jhc/System/C/Stdio.hs lib/jhc/System/Mem.hs lib/jhc/Prelude/CType.hs lib/jhc/Prelude/Text.hs lib/jhc/Prelude/Float.hs lib/jhc/Prelude/IO.hs lib/jhc/Foreign/Ptr.hs lib/jhc/Foreign/Storable.hs lib/jhc/Foreign/C/String.hs lib/jhc/Foreign/C/Types.hs lib/jhc/Foreign/C/Error.hs lib/jhc/Foreign/Storable.m4 lib/jhc/Foreign/Marshal/Alloc.hs lib/jhc/Foreign/Marshal/Utils.hs lib/jhc/Foreign/Marshal/Array.hs lib/jhc/jhc.yaml lib/jhc-prim/jhc-prim.yaml lib/jhc-prim/Jhc/Prim/Bits.hs lib/jhc-prim/Jhc/Prim/Prim.hs lib/jhc-prim/Jhc/Prim/Rts.hs lib/jhc-prim/Jhc/Prim/Array.hs lib/jhc-prim/Jhc/Prim/IO.hs lib/jhc-prim/Jhc/Prim/Wrapper.hs lib/haskell2010/haskell2010.yaml.m4 lib/ext/bytestring.patch lib/ext/smallcheck.cabal lib/ext/parsec.cabal lib/ext/containers.cabal lib/ext/utility-ht.cabal lib/ext/html.cabal lib/ext/filepath.cabal lib/ext/bytestring.yaml lib/ext/pretty.cabal lib/ext/HUnit.cabal lib/ext/transformers.cabal lib/ext/deepseq.cabal lib/ext/xhtml.cabal lib/ext/Diff.cabal lib/ext/containers.patch lib/ext/QuickCheck.cabal lib/ext/safe.cabal ++source-repository head+    type:     git+    location: https://github.com/ajhc/ajhc.git++executable ajhc+    main-is:        Main.hs+    hs-source-dirs: drift_processed src++    c-sources:+        src/StringTable/StringTable_cbits.c+        src/cbits/md5sum.c+        src/cbits/lookup3.c++    include-dirs:+        src/data, src/StringTable, src/cbits, src++    build-depends:+        base >= 4.0 && < 5,+        HsSyck,+        array,+        binary,+        bytestring,+        containers,+        directory,+        fgl,+        filepath,+        haskeline,+        mtl,+        old-time,+        pretty,+        process,+        random,+        regex-compat,+        syb,+        temporary,+        utf8-string,+        zlib++    if os(windows)+        build-depends: Win32+    else+        build-depends: unix++    other-modules:+        C.FFI+        C.FromGrin2+        C.Generate+        C.Prims+        Cmm.Number+        Cmm.Op+        Cmm.OpEval+        DataConstructors+        DerivingDrift.DataP+        DerivingDrift.Drift+        DerivingDrift.RuleUtils+        DerivingDrift.StandardRules+        Doc.Attr+        Doc.Chars+        Doc.DocLike+        Doc.PPrint+        Doc.Pretty+        E.Annotate+        E.Arbitrary+        E.Binary+        E.CPR+        E.Demand+        E.Diff+        E.E+        E.Eta+        E.Eval+        E.FreeVars+        E.FromHs+        E.Inline+        E.LambdaLift+        E.LetFloat+        E.Lint+        E.Main+        E.PrimDecode+        E.PrimOpt+        E.Program+        E.Rules+        E.SSimplify+        E.SStrictness+        E.Show+        E.Subst+        E.ToHs+        E.Traverse+        E.Type+        E.TypeAnalysis+        E.TypeCheck+        E.Values+        E.WorkerWrapper+        FindFixpoint+        Fixer.Fixer+        Fixer.Supply+        Fixer.VMap+        FlagDump+        FlagOpts+        FrontEnd.Class+        FrontEnd.DataConsAssump+        FrontEnd.DeclsDepends+        FrontEnd.DependAnalysis+        FrontEnd.Desugar+        FrontEnd.Diagnostic+        FrontEnd.Exports+        FrontEnd.FrontEnd+        FrontEnd.HsErrors+        FrontEnd.HsParser+        FrontEnd.HsPretty+        FrontEnd.HsSyn+        FrontEnd.Infix+        FrontEnd.KindInfer+        FrontEnd.Lexer+        FrontEnd.ParseMonad+        FrontEnd.ParseUtils+        FrontEnd.Rename+        FrontEnd.Representation+        FrontEnd.SrcLoc+        FrontEnd.Syn.Options+        FrontEnd.Syn.Traverse+        FrontEnd.Tc.Class+        FrontEnd.Tc.Kind+        FrontEnd.Tc.Main+        FrontEnd.Tc.Module+        FrontEnd.Tc.Monad+        FrontEnd.Tc.Type+        FrontEnd.Tc.Unify+        FrontEnd.TypeSigs+        FrontEnd.TypeSynonyms+        FrontEnd.TypeSyns+        FrontEnd.Unlit+        FrontEnd.Utils+        FrontEnd.Warning+        GenUtil+        Grin.Arity+        Grin.DeadCode+        Grin.Devolve+        Grin.Embed+        Grin.EvalInline+        Grin.FromE+        Grin.Grin+        Grin.HashConst+        Grin.Interpret+        Grin.Lint+        Grin.Main+        Grin.NodeAnalyze+        Grin.Noodle+        Grin.Optimize+        Grin.SSimplify+        Grin.Show+        Grin.StorageAnalysis+        Grin.Unboxing+        Grin.Val+        Grin.Whiz+        Ho.Binary+        Ho.Build+        Ho.Collected+        Ho.Library+        Ho.ReadSource+        Ho.Type+        Info.Binary+        Info.Info+        Info.Properties+        Info.Types+        Interactive+        Main+        Name.Binary+        Name.Id+        Name.Name+        Name.Names+        Name.Prim+        Name.VConsts+        Options+        PackedString+        RawFiles+        Stats+        StringTable.Atom+        Support.CFF+        Support.Cabal+        Support.CanType+        Support.Compat+        Support.CompatMingw32+        Support.FreeVars+        Support.IniParse+        Support.MD5+        Support.MapBinaryInstance+        Support.ShowTable+        Support.TempDir+        Support.Tickle+        Support.Transform+        Support.Tuple+        Support.Unparse+        Util.BitSet+        Util.BooleanSolver+        Util.ContextMonad+        Util.ExitCodes+        Util.FilterInput+        Util.GMap+        Util.Gen+        Util.Graph+        Util.Graphviz+        Util.HasSize+        Util.Histogram+        Util.Inst+        Util.IntBag+        Util.Interact+        Util.NameMonad+        Util.Once+        Util.Perhaps+        Util.Progress+        Util.RWS+        Util.ReaderWriter+        Util.Relation+        Util.SHA1+        Util.SameShape+        Util.Seq+        Util.SetLike+        Util.TrueSet+        Util.UnionFind+        Util.UnionSolve+        Util.UniqueMonad+        Util.Util+        Util.VarName+        Util.YAML+        Version.Config+        Version.Version+        Paths_ajhc++    extensions:+        BangPatterns, TypeFamilies, ViewPatterns, UndecidableInstances,+        OverlappingInstances, RecordWildCards, RecursiveDo, TupleSections,+        ParallelListComp, GeneralizedNewtypeDeriving, ScopedTypeVariables,+        FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses,+        DeriveDataTypeable, NoMonoLocalBinds, NamedFieldPuns,+        ForeignFunctionInterface, UnliftedFFITypes, ImplicitParams,+        UnboxedTuples, StandaloneDeriving, DeriveFunctor, DeriveFoldable,+        DeriveTraversable, FlexibleContexts,+        ConstrainedClassMethods, FunctionalDependencies, MagicHash,+        PolymorphicComponents, ExistentialQuantification, UnicodeSyntax,+        PostfixOperators, PatternGuards, LiberalTypeSynonyms, RankNTypes,+        TypeOperators, EmptyDataDecls, KindSignatures+    ghc-options:    -W -fno-warn-unused-matches  -fwarn-type-defaults -i./drift_processed -i./src+    cc-options:     -std=c99+    cpp-options:    -DUSE_HASKELINE -DWITH_CABAL
+ drift_processed/C/FFI.hs view
@@ -0,0 +1,52 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/C/FFI.hs" #-}+module C.FFI(+    CallConv(..),+    Safety(..),+    FfiType(..),+    FfiExport(..),+    FfiSpec(..),+    Requires(..)+    ) where++import C.Prims+import Data.Binary+import Data.Typeable++type CName = String++data FfiType = Import CName Requires+             | ImportAddr CName Requires+             | Wrapper+             | Dynamic+             deriving(Eq,Ord,Show)++data FfiSpec = FfiSpec FfiType Safety CallConv+             deriving(Eq,Ord,Show)++data FfiExport = FfiExport {+    ffiExportCName    :: CName,+    ffiExportSafety   :: Safety,+    ffiExportCallConv :: CallConv,+    ffiExportArgTypes :: [ExtType],+    ffiExportRetType  :: ExtType+    }+ deriving(Eq,Ord,Show,Typeable)+     {-! derive: Binary !-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary FfiExport where+    put (FfiExport aa ab ac ad ae) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+	    Data.Binary.put ae+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    ae <- get+    return (FfiExport aa ab ac ad ae)++--  Imported from other files :-
+ drift_processed/C/FromGrin2.hs view
@@ -0,0 +1,1012 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/C/FromGrin2.hs" #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards,ViewPatterns  #-}+module C.FromGrin2(compileGrin) where++import Control.Monad.Identity+import Control.Monad.RWS(asks,tell,local,get,runRWST,RWST,MonadState(..),MonadWriter(..),MonadReader(..))+import Data.Char+import Data.List+import Data.Maybe+import Data.Monoid(Monoid(..))+import System.FilePath+import Text.PrettyPrint.HughesPJ(nest,($$),fsep)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as BS+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Text.PrettyPrint.HughesPJ as P++import C.FFI+import C.Generate+import C.Prims+import Cmm.Number+import Doc.DocLike+import Doc.PPrint+import Grin.Grin+import Grin.HashConst+import Grin.Noodle+import Grin.Show()+import Grin.Val+import Options+import PackedString+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Gen+import Util.SetLike+import Util.UniqueMonad+import qualified Cmm.Op as Op+import qualified FlagOpts as FO++---------------+-- C Monad+---------------++data Todo = TodoReturn | TodoExp [Expression] | TodoDecl Name Type | TodoNothing++data Written = Written {+    wRequires :: Requires,+    wStructures :: Map.Map Name Structure,+    wTags :: Set.Set Atom,+    wAllocs :: Set.Set (Atom,Int),+    wEnums :: Map.Map Name Int,+    wFunctions :: Map.Map Name Function+    }+    {-! derive: Monoid !-}++-- special type representations when possible+data TyRep+    = TyRepRawTag    -- stored raw tag+    | TyRepUntagged  -- memory, without a tag+    | TyRepRawVal !Bool   -- stored raw argument and whether it is signed++data Env = Env {+    rTodo :: Todo,+    rInscope :: Set.Set Name,+    rStowed :: Set.Set Name,  -- names that the garbage collector knows about+    rDeclare :: Bool,+    rEMap :: Map.Map Atom (Name,[Expression]),+    rCPR  :: Map.Map Atom TyRep,+    rConst :: Set.Set Atom,+    rGrin :: Grin+    }++rEMap_u f r@Env{rEMap  = x} = r{rEMap = f x}+rInscope_u f r@Env{rInscope  = x} = r{rInscope = f x}++newtype C a = C (RWST Env Written HcHash Uniq a)+    deriving(Monad,UniqueProducer,MonadState HcHash,MonadWriter Written,MonadReader Env,Functor)++runC :: Grin -> C a -> ((a,HcHash,Written),Map.Map Atom TyRep)+runC grin (C m) =  (execUniq1 (runRWST m startEnv emptyHcHash),ityrep) where+    TyEnv tmap = grinTypeEnv grin+    ityrep = Map.mapMaybeWithKey tyRep (fromDistinctAscList $ Util.SetLike.toList tmap)+    startEnv = Env {+        rCPR = ityrep,+        rGrin = grin,+        rStowed = Set.empty,+        rDeclare = False,+        rTodo = TodoExp [],+        rEMap = mempty,+        rConst = Map.keysSet $ Map.filter isConst ityrep,+        rInscope = mempty+        }+    isConst TyRepRawVal {} = True+    isConst TyRepRawTag {} = True+    isConst _ = False+    tyRep k _ | k == cChar = Just $ TyRepRawVal False+    tyRep k _ | not (fopts FO.FullInt), k == cWord = Just $ TyRepRawVal False+    tyRep k _ | not (fopts FO.FullInt), k == cInt = Just $ TyRepRawVal True+    tyRep k TyTy { tySlots = [s], tySiblings = Just [k'] } | k == k', good s = Just $ TyRepRawVal False+    tyRep k tyty | null (tySlots tyty) = Just TyRepRawTag+    tyRep k tyty | Just xs <- tySiblings tyty, all triv [ x | x <- xs, x /= k] = Just TyRepUntagged where+        triv x = case mlookup x tmap of+            Just t -> null (tySlots t)+            Nothing -> False+    tyRep _ _ = Nothing+--    tyRep k tyty | tySiblings tyty == Just [k] = Just TyRepUntagged+    --cpr = iw `Map.union` Map.insert cChar False (Map.fromList [ (a,False) | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) <- Map.assocs tmap, a == a', isJust (good s) ])+    --iw = if fopts FO.FullInt then mempty else Map.fromList [(cInt,True), (cWord,False)]+    good s = isJust $ do+        ct <- Op.toCmmTy s+        b <- Op.cmmTyBits ct+        guard $ b <= 30+        Op.HintNone <- Op.cmmTyHint ct+        return ()++tellFunctions :: [Function] -> C ()+tellFunctions fs = tell mempty { wFunctions = Map.fromList $ map (\x -> (functionName x,x)) fs }++localTodo :: Todo -> C a -> C a+localTodo todo (C act) = C $ local (\ r -> r { rTodo = todo }) act++--------------+-- entry point+--------------++{-# NOINLINE compileGrin #-}+compileGrin :: Grin -> (LBS.ByteString,Requires)+compileGrin grin = (LBS.fromChunks code, req)  where+    code = [+        BS.fromString "#include \"jhc_rts_header.h\"\n",+        BS.fromString $ P.render ans,+        BS.fromString "\n"+        ]+    ans = vcat [+        vcat jgcs,+        vcat includes,+--        vcat cincludes,+        text "",+        enum_tag_t,+        header,+        cafs,+        buildConstants cpr grin finalHcHash,+        text "",+        nh_stuff,+        text "",+        body+        ]+    jgcs | fopts FO.Jgc = [ text "static struct s_cache *" <> tshow (nodeCacheName m) <> char ';' | (m,_) <- Set.toList wAllocs]+         | otherwise = empty+    fromRequires (Requires s) = map (unpackPS . snd) (Set.toList s)+    nh_stuff  = text "const void * const nh_stuff[] = {" $$ fsep (punctuate (char ',') (cafnames ++ constnames ++ [text "NULL"]))  $$ text "};"+    includes  = map include (filter ((".h" ==) . takeExtension)  $ fromRequires req)+--    cincludes = map include (filter ((".c" ==) . takeExtension) $ fromRequires req)+    include fn = text "#include <" <> text fn <> text ">"+    (header,body) = generateC (function (name "jhc_hs_init") voidType [] [Public] icaches:Map.elems fm) (Map.elems sm)+    icaches :: Statement+    icaches | fopts FO.Jgc = mconcat [  toStatement $ functionCall (name "find_cache") [reference (toExpression $ nodeCacheName t),toExpression $ name "arena", tbsize (sizeof (structType $ nodeStructName t)), toExpression nptrs] | (t,nptrs) <- Set.toList wAllocs ]+            | otherwise = mempty+    cafnames = [ text "&_" <> tshow (varName v) | (v,_) <- grinCafs grin ]+    constnames =  map (\n -> text "&_c" <> tshow n) [ 1 .. length $ Grin.HashConst.toList finalHcHash]+    ((cafs',finalHcHash,Written { wRequires = req, wFunctions = fm, wEnums = wenum, wStructures = sm, wTags = ts, .. }),cpr) = runC grin $ go >> mapM convertCAF (grinCafs grin)+    enum_tag_t | null enums = mempty+               | otherwise  = text "enum {" $$ nest 4 (P.vcat (punctuate P.comma $ enums)) $$ text "};"+        where+            f t n = tshow t <> text " = " <> tshow (n :: Int)+            enums =  map (uncurry f) (Map.toList wenum) ++ (zipWith f (Set.toList (Set.map nodeTagName ts)) [0 ..])+    go = do+        funcs <- liftM concat $ flip mapM (grinFuncs grin) $ \(a,l) -> do+                    convertFunc (mlookup a (grinEntryPoints grin)) (a,l)+        tellFunctions funcs+        h <- get+        let tset = Set.fromList [ n | (HcNode n (_:_),_) <- hconsts]+            tset' = Set.fromList [ n | (HcNode n [],_) <- hconsts]+            hconsts = Grin.HashConst.toList h+        mapM_ tellAllTags [ v  | (HcNode _ vs,_) <- hconsts, Left v <- vs]+        mapM_ declareStruct  (Set.toList tset)+        mapM_ tellTags (Set.toList $ tset `mappend` tset')+    cafs = text "/* CAFS */" $$ (vcat $ cafs')+    convertCAF (v,val@(NodeC a [])) = do+        en <- declareEvalFunc True a+        let ef =  drawG $ f_TO_FPTR (reference $ variable en)+        let ts =  text "/* " <> text (show v) <> text " = " <> (text $ P.render (pprint val)) <> text "*/\n" <>+                text "static node_t _" <> tshow (varName v) <> text " = { .head = " <> ef <> text " };\n" <>+                text "#define " <> tshow (varName v) <+>  text "(MKLAZY_C(&_" <> tshow (varName v) <> text "))\n";+        return ts+    convertCAF _ = error "FromGrin2.compileGrin: bad."++convertFunc :: Maybe FfiExport -> (Atom,Lam) -> C [Function]+convertFunc ffie (n,as :-> body) = do+        s <- localTodo TodoReturn (convertBody body)+        let bt = getType body+            mmalloc [TyINode] = [a_MALLOC]+            mmalloc [TyNode] = [a_MALLOC]+            mmalloc _ = []+            ats = a_STD:mmalloc bt+            fnname = nodeFuncName n++        fr <- convertTypes bt+        as' <- flip mapM (zip [1 :: Int .. ] as) $ \ (ix,(Var v t)) -> do+            t' <- convertType t+            return $ if v == v0 then (name $ 'u':show ix,t') else (varName v,t')++        mstub <- case ffie of+                Nothing -> return []+                Just ~(FfiExport cn Safe CCall argTys retTy) -> do+                    newVars <- mapM (liftM (name . show) . newVar . basicType') argTys++                    let fnname2 = name cn+                        as2 = zip (newVars) (map basicType' argTys)+                        fr2 = basicType' retTy++                    return [function fnname2 fr2 as2 [Public]+                                     (creturn $ cast fr2 $ functionCall fnname $ (if fopts FO.Jgc then (variable (name "saved_gc"):) else id) $+                                      zipWith cast (map snd as')+                                                   (map variable newVars))]++        return (function fnname fr (mgct as') ats s : mstub)++fetchVar :: Var -> Ty -> C Expression+fetchVar (V 0) _ = return $ noAssign (err "fetchVar v0")+fetchVar v@(V n) _ | n < 0 = return $ (variable  $ varName v)+fetchVar v ty = do+    t <- convertType ty+    is <- asks rInscope+    let n = varName v+    dclare <- asks rDeclare+    return $ (if v == v0 then noAssign else id) $ if not dclare then variable n else localVariable t n++fetchVar' :: Var -> Ty -> C (Name,Type)+fetchVar' (V n) _ | n < 0 = error "fetchVar': CAF"+fetchVar' v ty = do+    t <- convertType ty+    return $ (varName v,t)++convertVals :: [Val] -> C Expression+convertVals [] = return emptyExpression+convertVals [x] = convertVal x+convertVals xs = do+    ts <- mapM convertType (map getType xs)+    xs <- mapM convertVal xs+    return (structAnon (zip xs ts))++convertVal :: Val -> C Expression+convertVal v = cvc v where+    cvc v = convertConst v >>= maybe (cv v) return+    cv (Var v ty) = fetchVar v ty+    cv (Const h) = do+        cpr <- asks rConst+        case h of+            NodeC a ts -> do+                bn <- basicNode a ts+                case bn of+                    Just bn ->  return (cast sptr_t bn)+                    _ -> do+                        (_,i) <- newConst cpr h+                        return $ variable (name $  'c':show i )+            _ -> do+                (_,i) <- newConst cpr h+                return $ variable (name $  'c':show i )+    cv h@(NodeC a ts) | valIsConstant h = do+        cpr <- asks rConst+        bn <- basicNode a ts+        case bn of+            Just bn -> return bn+            _ -> do+                (_,i) <- newConst cpr h+                return $ f_PROMOTE (variable (name $  'c':show i ))++    cv (ValPrim p [x] (TyPrim opty)) = do+        x' <- convertVal x+        case p of+            Op (Op.UnOp n ta) r -> primUnOp n ta r x'+            Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x'+            x -> return $ err ("convertVal: " ++ show x)+    cv (ValPrim p [x,y] _) = do+        x' <- convertVal x+        y' <- convertVal y+        case p of+            Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y'+            x -> return $ err ("convertVal: " ++ show x)++    cv x = return $ err ("convertVal: " ++ show x)++convertTypes [] = return voidType+convertTypes [t] = convertType t+convertTypes xs = do+    xs <- mapM convertType xs+    return (anonStructType xs)++convertType TyNode = return wptr_t+convertType TyINode = return sptr_t+convertType (TyPtr TyINode) = return $ ptrType sptr_t+convertType (TyPtr TyNode) = return $ ptrType wptr_t+convertType ~(TyPrim opty) = return (opTyToC opty)++tyToC _ Op.TyBool = "bool"+tyToC dh (Op.TyComplex ty) = "_Complex " ++ tyToC dh ty+tyToC dh (Op.TyBits (Op.BitsExt s) _) = s+tyToC dh (Op.TyBits b h) = f b h where+    f b Op.HintNone = f b dh+    f b Op.HintUnsigned = case b of+        (Op.Bits n) ->  "uint" ++ show n ++ "_t"+        (Op.BitsArch Op.BitsMax) -> "uintmax_t"+        (Op.BitsArch Op.BitsPtr) -> "uintptr_t"+        _ -> error "tyToC: unknown"+    f b Op.HintSigned = case b of+        (Op.Bits n) ->  "int" ++ show n ++ "_t"+        (Op.BitsArch Op.BitsMax) -> "intmax_t"+        (Op.BitsArch Op.BitsPtr) -> "intptr_t"+        _ -> error "tyToC: unknown"+    f b Op.HintFloat = case b of+        (Op.Bits 32) -> "float"+        (Op.Bits 64) -> "double"+        (Op.Bits 128) -> "__float128"+        _ -> error "tyToC: unknown"+    f _ _ = error "tyToC: unknown"+tyToC _ _ = error "FromGrin2.tToC: bad."++opTyToCh hint opty = basicType (tyToC hint opty)+opTyToC opty = basicType (tyToC Op.HintUnsigned opty)+opTyToC' opty = tyToC Op.HintUnsigned opty++localScope xs action = do+    let fvs = freeVars xs+    aas <- mapM (\ (v,t) -> do t <- convertType t ; return . toStatement $ localVariable t (varName v)) (filter ((v0 /=) . fst) $ Set.toList fvs)+    local (rInscope_u $ Set.union (Set.map varName (freeVars xs))) (action . statementOOB $ mconcat aas)++iDeclare action = local (\e -> e { rDeclare = True }) action++convertBody :: Exp -> C Statement+convertBody Let { expDefs = defs, expBody = body } = do+    u <- newUniq+    nn <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> _ } -> do+        vs' <- mapM convertVal as+        let nm = (toName (show name ++ "_" ++ show u))+        return (as,(name,(nm,vs')))+    let done = (toName $ "done" ++ show u)+    let localJumps xs action = localScope (fsts xs) $ \dcls ->  local (rEMap_u (Map.fromList (snds xs) `mappend`)) (fmap (dcls &) action)+    localJumps nn $ do+    rs <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> b } -> do+        ss <- convertBody b+        return (annotate (show as) (label (toName (show name ++ "_" ++ show u))) & subBlock ss)+    ss <- (convertBody body)+    todo <- asks rTodo+    case todo of+        TodoReturn -> return (ss & mconcat rs);+        _ -> return (ss & goto done & mconcat (intersperse (goto done) rs) & label done);+convertBody (e :>>= [] :-> e') = do+    ss <- localTodo TodoNothing (convertBody e)+    ss' <- convertBody e'+    return (ss & ss')+convertBody (Return [v] :>>= [(NodeC t as)] :-> e') = nodeAssign v t as e'+--convertBody (Fetch v :>>= [(NodeC t as)] :-> e') = nodeAssign v t as e'+convertBody (Case v [p1@([NodeC _ (_:_)] :-> _),p2@([NodeC _ []] :-> _)]) = convertBody $ Case v [p2,p1]+convertBody (Case v@(getType -> TyNode) [[p1@(NodeC t fps)] :-> e1,[p2] :-> e2]) = do+    scrut <- convertVal v+    cpr <- asks rConst+    tellTags t+    let da (Var v _) e | v == v0 = convertBody e+        da v@Var {} e = do+            v'' <- iDeclare $ convertVal v+            e' <- convertBody e+            return $ v'' =* scrut & e'+        da n1@(NodeC t _) (Return [n2@NodeC {}]) | n1 == n2 = convertBody (Return [v])+        da ~(NodeC t as) e = nodeAssign v t as e+        am Var {} e = return e+        am ~(NodeC t2 _) e = do+            --tellTags t2+            --return $ annotate (show p2) (f_assert ((constant $ enum (nodeTagName t2)) `eq` tag) & e)+            return $ annotate (show p2) e+        tag = if null fps then f_FETCH_RAW_TAG scrut else f_FETCH_TAG scrut+        ifscrut = if null fps then f_SET_RAW_TAG tenum `eq` scrut else tenum `eq` tag where+            tenum = (constant $ enum (nodeTagName t))+    p1' <- da p1 e1+    p2' <- am p2 =<< da p2 e2+    return $ cif ifscrut p1' p2'++-- zero is usually faster to test for than other values, so flip them if zero is being tested for.+convertBody (Case v [v1, v2@([Lit n _] :-> _)]) | n == 0 = convertBody (Case v [v2,v1])+convertBody (Case v@(getType -> t) [[p1] :-> e1, [p2] :-> e2]) | Set.null ((freeVars p2 :: Set.Set Var) `Set.intersection` freeVars e2) = do+    scrut <- convertVal v+    let cp ~(Lit i _) = constant (number $ fromIntegral i)+        am e | isVar p2 = e+             | otherwise = annotate (show p2) (f_assert ((cp p2) `eq` scrut) & e)+    e1' <- convertBody e1+    e2' <- convertBody e2+    return $ cif (cp p1 `eq` scrut) e1' (am e2')+convertBody (Case v@(getType -> TyNode) ls) = do+    scrut <- convertVal v+    let tag = f_FETCH_TAG scrut+        da ([(Var v _)] :-> e) | v == v0 = do+            e' <- convertBody e+            return $ (Nothing,e')+        da ([v@(Var {})] :-> e) = do+            v'' <- iDeclare $ convertVal v+            e' <- convertBody e+            return $ (Nothing,v'' =* scrut & e')+        da ([n1@(NodeC t _)] :-> Return [n2@NodeC {}]) | n1 == n2 = do+            tellTags t+            e' <- convertBody (Return [v])+            return (Just (enum (nodeTagName t)),e')+        da (~[(NodeC t as)] :-> e) = do+            tellTags t+            declareStruct t+            as' <- iDeclare $ mapM convertVal as+            e' <- convertBody e+            let tmp = concrete t scrut+                ass = mconcat [if needed a then a' =* (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]+                fve = freeVars e+                needed ~(Var v _) = v `Set.member` fve+            return $ (Just (enum (nodeTagName t)), ass & e')+    ls' <- mapM da ls+    return $ switch' tag ls'+convertBody (Case v ls) = do+    scrut <- convertVal v+    let da ([(Var vv _)] :-> e) | vv == v0 = do+            e' <- convertBody e+            return (Nothing,e')+        da ([v@(Var {})] :-> e) = do+            v'' <- iDeclare $ convertVal v+            e' <- convertBody e+            return (Nothing,v'' =* scrut & e')+        da (~[(Lit i _)] :-> e) = do+            e' <- convertBody e+            return $ (Just (number $ fromIntegral i), e')+        --da (~[x] :-> e) = da ( x :-> e )+    ls' <- mapM da ls+    return $ switch' scrut ls'+convertBody (Error s t) = do+    x <- asks rTodo+    let jerr | null s    = toStatement $ functionCall (name "jhc_exit") [constant $ number 255]+             | otherwise = toStatement $ functionCall (name "jhc_error") [string s]+    let f (TyPtr _) = return nullPtr+        f TyNode = return nullPtr+        f TyINode = return nullPtr+        f (TyPrim x) = return $ cast (opTyToC x) (constant $ number 0)+        f x = return $ err ("error-type " ++ show x)+        g [] = return emptyExpression+        g [x] = f x+        g xs = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts)+    case x of+        TodoNothing -> return jerr+        TodoExp _ -> return jerr+        TodoDecl {} -> return jerr+        TodoReturn -> do+            v <- g t+            return (jerr & creturn v)++convertBody (BaseOp (StoreNode b) [n@NodeC {}]) = newNode region_heap (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v)+convertBody (BaseOp (StoreNode b) [n@NodeC {},region]) = newNode region (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v)++convertBody (e :>>= [(Var vn _)] :-> e') | vn == v0 = do+    ss <- localTodo TodoNothing (convertBody e)+    ss' <- convertBody e'+    return (ss & ss')++convertBody (e :>>= [(Var vn' vt')] :-> e') | not (isCompound e) = do+    (vn,vt) <- fetchVar' vn' vt'+    ss <- localTodo (TodoDecl vn vt) (convertBody e)+    ss' <- convertBody e'+    return (ss & ss')++convertBody (e :>>= [v@(Var vn vt)] :-> e') = do+    v' <- convertVal v+    vt <- convertType vt+    let sdecl = statementOOB $ toStatement (localVariable vt (varName vn))+    ss <- localTodo (TodoExp [v'])  (convertBody e)+    ss' <- convertBody e'+    return (sdecl & ss & ss')++convertBody (e :>>= xs@(_:_:_) :-> e') = do+    ts <- mapM (convertType . getType) xs+    (dcl,st) <- newDeclVar (anonStructType ts)+    vs <- iDeclare $ mapM convertVal xs+    ss <- localTodo (TodoExp [st]) (convertBody e)+    ss' <- convertBody e'+    return $ dcl & ss & mconcat [ v =* projectAnon i st | v <- vs | i <- [0..] ] & ss'++-- mutable arrays and iorefs+convertBody (BaseOp PokeVal [Index base off,z])  = do+    base <- convertVal base+    off <- convertVal off+    z' <- convertVal z+    return $ indexArray base off =* z'+convertBody (BaseOp PokeVal [base,z])  = do+    base <- convertVal base+    z' <- convertVal z+    return $ indexArray base (constant $ number 0) =* z'+convertBody (BaseOp PeekVal [Index base off]) | getType base == TyPtr tyINode = do+    base <- convertVal base+    off <- convertVal off+    simpleRet (indexArray base off)+convertBody (BaseOp (Coerce ty) [v])  = do+    v <- convertVal v+    ty <- convertType ty+    simpleRet $ cast ty v+convertBody (GcRoots vs b) = do+    vs <- mapM convertVal vs+    b' <- convertBody b+    return $ subBlock (gc_roots vs & b')++-- return, promote and demote+convertBody (BaseOp Promote [v])       | getType v == tyINode = simpleRet =<< f_promote `liftM` convertVal v+convertBody (BaseOp Demote [n@Var {}]) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n+--convertBody (Store n@Var {}) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n++convertBody (Return []) = simpleRet emptyExpression+convertBody (Return [v]) = simpleRet =<< convertVal v+convertBody (Return xs@(_:_:_)) = do+    t <- asks rTodo+    case t of+        TodoExp [e] -> do+            xs <- mapM convertVal xs+            ss <- forMn xs $ \ (v,i) -> return (projectAnon i e =* v)+            return (mconcat ss)+        _ -> simpleRet =<< convertVals xs++convertBody e = do+    x <- asks rTodo+    (ss,er) <- convertExp e+    r <- simpleRet er+    return (ss & r)++simpleRet er = do+    x <- asks rTodo+    case x of+        TodoReturn -> return (creturn er)+        _ | isEmptyExpression er -> return mempty+        TodoNothing -> return (toStatement er)+        TodoExp [v] -> return (v =* er)+        TodoDecl n t -> do newAssignVar t n er+        TodoExp [] -> return $ toStatement er+        _ -> error "simpleRet: odd rTodo"++nodeAssign :: Val -> Atom -> [Val] -> Exp -> C Statement+nodeAssign v t as e' = do+    cpr <- asks rCPR+    v' <- convertVal v+    case mlookup t cpr of+        Just (TyRepRawVal signed) -> do+            [arg] <- return as+            t <- convertType $ getType arg+            arg' <- iDeclare $ convertVal arg+            let s = arg' =* cast t (if signed then f_RAW_GET_F v' else f_RAW_GET_UF v')+            ss <- convertBody e'+            return $ s & ss+        _ -> do+            declareStruct t+            as' <- iDeclare $ mapM convertVal as+            let ass = concat [perhapsM (a `Set.member` fve) $ a' =* (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as |  i <- [( 1 :: Int) ..] ]+                fve = freeVars e'+            ss' <- convertBody e'+            return $ mconcat ass & ss'++--isCompound Fetch {} = False+isCompound BaseOp {} = False+isCompound Return {} = False+--isCompound Store {} = False+isCompound Prim {} = False+isCompound _ = True++mgc = if fopts FO.Jgc then (v_gc:) else id+mgct = if fopts FO.Jgc then ((name "gc",gc_t):) else id++convertExp :: Exp -> C (Statement,Expression)+convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do+    tell mempty { wRequires = primRequires }+    vs' <- mapM convertVal vs+    rt <- mapM convertType ty+    --let rrs = map basicType' (r:rs)+    ras <- mapM (newVar . basicType') rs+    (stmt,rv) <- basicType' r `newTmpVar` (functionCall (name $ unpackPS funcName) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras))+    return $ (stmt, structAnon (zip (rv:ras) rt))+convertExp (Prim Func { primRetArgs = [], .. } vs ty) = do+    tell mempty { wRequires = primRequires }+    vs' <- mapM convertVal vs+    rt <- convertTypes ty+    let fcall =  cast rt (functionCall (name $ unpackPS funcName) [ cast (basicType' t) v | v <- vs' | t <- primArgTypes ])+    return (if primSafety == Safe && fopts FO.Jgc then v_saved_gc =* v_gc else mempty,fcall)+convertExp (Prim p vs ty) =  do+    tell mempty { wRequires = primReqs p }+    e <- convertPrim p vs ty+    return (mempty,e)++--convertExp (App a [fn,x] _) | a == funcApply = do+--    fn' <- convertVal fn+--    x' <- convertVal x+--    return (mempty,(functionCall (name "eval") [v']))+convertExp (BaseOp Eval [v]) = do+    v' <- convertVal v+    return (mempty,f_eval v')+convertExp (BaseOp GcTouch _) = do+    return (mempty, emptyExpression)+convertExp (App a vs _) = do+    lm <- asks rEMap+    vs' <- mapM convertVal vs+    case a `mlookup` lm of+        Just (nm,as) -> do+            let ss = [ a =* v | a <- as | v <- vs' ]+            return (mconcat ss & goto nm, emptyExpression)+        Nothing -> return $ (mempty, functionCall (toName (fromAtom a)) (mgc vs'))+convertExp (BaseOp Overwrite [v@(Var vv _),tn@(NodeC t as)]) | getType v == TyINode = do+    v' <- convertVal v+    as' <- mapM convertVal as+    nt <- nodeTypePtr t+    let tmp' = cast nt (f_FROM_SPTR v')+    if not (tagIsSuspFunction t) && vv < v0 then do+        (nns, nn) <- newNode region_heap fptr_t tn+        return (nns & getHead (f_NODEP(f_FROM_SPTR v')) =* nn,emptyExpression)+     else do+        s <- tagAssign tmp' t+        let ass = [project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ]+        return (mconcat $ s:ass,emptyExpression)++convertExp Alloc { expValue = v, expCount = c, expRegion = r }+        | r == region_heap, TyINode == getType v  = do+    v' <- convertVal v+    c' <- convertVal c+    (malloc,tmp) <- jhc_malloc_ptrs c' =:: ptrType sptr_t+    fill <- case v of+        ValUnknown _ -> return mempty+        _ -> do+            i <- newVar (basicType "int")+            return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v'+    return (malloc `mappend` fill, tmp)+convertExp Alloc { expValue = v, expCount = c, expRegion = r } |+    r == region_atomic_heap, TyPrim Op.bits_ptr == getType v  = do+        v' <- convertVal v+        c' <- convertVal c+        (malloc,tmp) <- jhc_malloc_atomic c' =:: ptrType uintptr_t+        fill <- case v of+            ValUnknown _ -> return mempty+            _ -> do+                i <- newVar (basicType "int")+                return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v'+        return (malloc `mappend` fill, tmp)++convertExp e = return (err (show e),err "nothing")++{-+ccaf :: (Var,Val) -> P.Doc+ccaf (v,val) = text "/* " <> text (show v) <> text " = " <>+    (text $ P.render (pprint val)) <> text "*/\n" <>+     text "static node_t _" <> tshow (varName v) <> text ";\n" <>+     text "#define " <> tshow (varName v) <+>  text "(MKLAZY_C(&_" <>+     tshow (varName v) <> text "))\n";+-}++buildConstants cpr grin fh = P.vcat (map cc (Grin.HashConst.toList fh)) where+    --tyenv = grinTypeEnv grin+    comm nn = text "/* " <> tshow (nn) <> text " */"+    cc nn@(HcNode a zs,i) = comm nn $$ cd $$ def where+        cd = text "static const struct" <+> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (ntag ++ rs)) <> text "};"+        --Just TyTy { tySiblings = sibs } = findTyTy tyenv a+        ntag = case mlookup a cpr of+            --Just [a'] | a' == a -> []+            Just _ -> []+            _ -> [text ".what =" <+> text "(what_t)SET_RAW_TAG(" <> tshow (nodeTagName a) <> text ")"]+        def = text "#define c" <> tshow i <+> text "(TO_SPTR_C(P_WHNF, (sptr_t)&_c" <> tshow i <> text "))"+        rs = [ f z i |  (z,i) <- zip zs [ 1 :: Int .. ]]+        f (Right i) a = text ".a" <> tshow a <+> text "=" <+> text ('c':show i)+        f (Left (Var n _)) a = text ".a" <> tshow a <+> text "=" <+> tshow (varName n)+        f (Left v) a = text ".a" <> tshow a <+> text "=" <+> text (show $ drawG e) where+            Just e = fst3 . fst . runC grin $ convertConst v++convertConst :: Val -> C (Maybe Expression)+convertConst (NodeC n as) | all valIsConstant as = basicNode n as+convertConst (Const (NodeC n as)) = fmap (fmap $ cast sptr_t) $ basicNode n as+convertConst v = return (f v) where+    f :: Val -> Maybe Expression+    f (Lit i (TyPrim Op.TyBool)) = return $ toExpression (i /= 0)+    f (Lit i (TyPrim (Op.TyBits _ Op.HintFloat))) = return (constant $ floating (realToFrac i))+    f (Lit i _) = return (constant $ number (fromIntegral i))+    f (ValPrim p [] ty) = case p of+        CConst _ s -> return $ expressionRaw $ unpackPS s+        AddrOf _ t -> do rt <- convertType ty; return . cast rt $ expressionRaw ('&':unpackPS t)+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimSizeOf } ->+            return $ expressionRaw ("sizeof(" ++ tyToC Op.HintUnsigned arg ++ ")")+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMinBound } ->+            return $ expressionRaw ("prim_minbound(" ++ tyToC Op.HintUnsigned arg ++ ")")+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMaxBound } ->+            return $ expressionRaw ("prim_maxbound(" ++ tyToC Op.HintUnsigned arg ++ ")")+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimUMaxBound } ->+            return $ expressionRaw ("prim_umaxbound(" ++ tyToC Op.HintUnsigned arg ++ ")")+        PrimString s -> return $ cast (basicType "uintptr_t") (expressionRaw (show s))+        x -> return $ err (show x)+    f (ValPrim p [x] (TyPrim opty)) = do+        x' <- f x+        case p of+            Op (Op.UnOp n ta) r -> primUnOp n ta r x'+            Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x'+            x -> return $ err (show x)+    f (ValPrim p [x,y] _) = do+        x' <- f x+        y' <- f y+        case p of+            Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y'+            x -> return $ err (show x)+    f x = fail "f"++--convertPrim p vs = return (mempty,err $ show p)+convertPrim p vs ty+    | (CConst _ s) <- p = do+        return $ expressionRaw $ unpackPS s+    | Op {} <- p = do+        let [rt] = ty+        convertVal (ValPrim p vs rt)+    | (IFunc _ as r) <- p = do+        v':vs' <- mapM convertVal vs+        rt <- convertTypes ty+        let fn = cast (funPtrType (basicType' r) (map basicType' as)) v'+        return $ cast (rt) (indirectFunctionCall fn [ cast (basicType' t) v | v <- vs' | t <- as ])+    | (Peek t) <- p, [v] <- vs = do+        v' <- convertVal v+        return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> char ')')+    | (Poke t) <- p, [v,x] <- vs = do+        v' <- convertVal v+        x' <- convertVal x+        return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> text ") = " <> renderG x')+    | (AddrOf _ t) <- p, [] <- vs = do+        rt <- convertTypes ty+        return . cast rt $ expressionRaw ('&':unpackPS t)+    | otherwise = return $ err ("prim: " ++ show (p,vs))++signedOps = [+--    (Op.Div,"/"),  -- TODO round to -Infinity+--    (Op.Mod,"%"),  -- TODO round to -Infinity+    (Op.Quot,"/"),+    (Op.Rem,"%"),+    (Op.Shra,">>"),+    (Op.Gt,">"),+    (Op.Lt,"<"),+    (Op.Gte,">="),+    (Op.Lte,"<=")+    ]++floatOps = [+    (Op.FDiv,"/"),+    (Op.FAdd,"+"),+    (Op.FSub,"-"),+    (Op.FMul,"*"),+    (Op.FEq,"=="),+    (Op.FNEq,"!="),+    (Op.FGt,">"),+    (Op.FLt,"<"),+    (Op.FGte,">="),+    (Op.FLte,"<=")+    ]++binopSigned :: Op.BinOp -> Maybe String+binopSigned b = lookup b signedOps++castSigned ty v = return $ cast (basicType $ tyToC Op.HintSigned ty) v++primBinOp n ta tb r a b+    | Just fn <- Op.binopFunc ta tb n = return $ functionCall (toName fn) [a,b]+    | Just (t,_) <- Op.binopInfix n = return $ operator t a b+    | Just t <- binopSigned n = do+        a <- castSigned ta a+        b <- castSigned tb b+        return $ operator t a b+    | Just t <- lookup n floatOps = return $ operator t a b+    | otherwise = return $ err ("primBinOp: " ++ show ((n,ta,tb,r),a,b))++primUnOp Op.Neg ta r a = do+    a <- castSigned ta a+    return $ uoperator "-" a+primUnOp Op.Com ta r a = do return $ uoperator "~" a+primUnOp Op.FNeg ta r a = do return $ uoperator "-" a+primUnOp op ta r a | Just fn <- Op.unopFloat ta op = return $ functionCall (toName fn) [a]+primUnOp n ta r a+    | otherwise = return $ err ("primUnOp: " ++ show ((n,ta,r),a))++tagAssign :: Expression -> Atom -> C Statement+tagAssign e t | tagIsSuspFunction t = do+    en <- declareEvalFunc False t+    return $ getHead e =* f_TO_FPTR (reference (variable en))+tagAssign e t = do+    cpr <- asks rCPR+    declareStruct t+    tyenv <- asks (grinTypeEnv . rGrin)+    --TyTy { tySiblings = sib } <- findTyTy tyenv t+    case mlookup t cpr of+        --Just [n'] | n' == t -> return mempty+        Just _ -> return mempty+        _ -> do+            tellTags t+            return . toStatement $ f_SET_MEM_TAG e (constant (enum $ nodeTagName t))++tellAllTags :: Val -> C ()+tellAllTags (NodeC n vs) = tellTags n >> mapM_ tellAllTags vs+tellAllTags n = mapValVal tt n >> return () where+    tt v = tellAllTags v >> return v++tellTags :: Atom -> C ()+tellTags t | tagIsSuspFunction t = return ()+tellTags t = do+    tyenv <- asks (grinTypeEnv . rGrin)+    TyTy { tySiblings = sib } <- findTyTy tyenv t+    case sib of+--        Just [n'] | n' == t ->  return ()+        Just rs -> tell mempty { wEnums = Map.fromList (zip (map nodeTagName rs) [0..]) }+        Nothing -> tell mempty { wTags = Set.singleton t }++newNode region ty ~(NodeC t as) = do+    let sf = tagIsSuspFunction t+    bn <- basicNode t as+    cpr <- asks rCPR+    case bn of+      Just e -> return (mempty,if ty == wptr_t then e else cast ty e)+      Nothing -> do+        st <- nodeType t+        as' <- mapM convertVal as+        let wmalloc | fopts FO.Jgc = \_ -> functionCall (name "s_alloc") [toExpression $ name "gc", (toExpression $ nodeCacheName t)]+                    | otherwise = jhc_malloc (reference (toExpression $ nodeCacheName t)) nptrs'+            nptrs = length (filter (not . nonPtr . getType) as) + if sf then 1 else 0+            nptrs' = if nptrs > 0 && not sf && t `Map.notMember` cpr then nptrs + 1 else nptrs+            malloc =  wmalloc (sizeof st)+            nonPtr TyPtr {} = False+            nonPtr TyNode = False+            nonPtr TyINode = False+            nonPtr _ = True+        (dtmp,tmp) <- case region == region_stack of+            True -> do+                v <- newVar st+                return (mempty,reference v)+            False -> do+                tell mempty { wAllocs = Set.singleton (t,nptrs') }+                ty `newTmpVar` malloc+        let tmp' = concrete t tmp+            ass = [ if isValUnknown aa then mempty else project' i tmp' =* a | a <- as' | aa <- as | i <- map arg [(1 :: Int) ..] ]+        tagassign <- tagAssign tmp' t+        let res = if sf then (f_MKLAZY tmp) else tmp+        return (mconcat $ dtmp:tagassign:ass,res)++------------------+-- declaring stuff+------------------++declareStruct n = do+    grin <- asks rGrin+    cpr <- asks rCPR+    let TyTy { tySlots = ts, tySiblings = ss } = runIdentity $ findTyTy (grinTypeEnv grin) n+    ts' <- mapM convertType ts+    let (dis,needsDis) | tagIsSuspFunction n = ([(name "head",fptr_t)],False)+                       | null ts = ([],False)+                       | Just TyRepUntagged <- mlookup n cpr = ([],False)+                       | Just [n'] <- ss, n == n' = ([],False)+                       | otherwise = ([],True)+        fields = (dis ++ zip [ name $ 'a':show i | i <-  [(1 :: Int) ..] ] ts')+        theStruct = basicStructure {+            structureName = nodeStructName n,+            structureFields = fields,+            structureAligned = True,+            structureHasDiscriminator = not $ null dis,+            --structureNeedsDiscriminator = not (fopts FO.Jgc) &&  needsDis+            structureNeedsDiscriminator =  needsDis+            }+    unless (null fields) $ tell mempty { wStructures = Map.singleton (structureName theStruct) theStruct }++basicNode :: Atom -> [Val] -> C (Maybe Expression)+basicNode a _ | tagIsSuspFunction a = return Nothing+basicNode a []  = do tellTags a ; return . Just $ (f_SET_RAW_TAG (constant $ enum (nodeTagName a)))+basicNode a [v] = do+    cpr <- asks rCPR+    case mlookup a cpr of+        Just (TyRepRawVal signed) -> case v of+            Lit i ty | a == cChar, Just c <- ch -> return $ Just (f_RAW_SET_UF (toExpression c)) where+                ch = do+                    c <- toIntegral i+                    guard $ c >= ord minBound && c <= ord maxBound+                    c <- return $ chr c+                    guard $ isPrint c && isAscii c+                    return c+            _ -> do+                v <- convertVal v+                return $ Just (if signed then f_RAW_SET_F v else f_RAW_SET_UF v)+        _ -> return Nothing+basicNode _ _ = return Nothing++instance Op.ToCmmTy Ty where+    toCmmTy (TyPrim p) = Just p+    toCmmTy _ = Nothing++declareEvalFunc isCAF n = do+    fn <- tagToFunction n+    grin <- asks rGrin+    declareStruct n+    nt <- nodeType n+    let ts = runIdentity $ findArgs (grinTypeEnv grin) n+        fname = toName $ "E_" ++ show fn+        aname = name "arg"+        rvar = localVariable wptr_t (name "r")+        atype = ptrType nt+        body = rvar =* functionCall (toName (show $ fn)) (mgc [ project' (arg i) (variable aname) | _ <- ts | i <- [(1 :: Int) .. ] ])+        update =  f_update (variable aname) rvar+        addroot =  if isCAF && fopts FO.Jgc then f_gc_add_root (cast sptr_t rvar) else emptyExpression+        body' = if not isCAF && fopts FO.Jgc then subBlock (gc_roots [f_MKLAZY(variable aname)] & rest) else rest+        rest = body & update & addroot & creturn rvar+    tellFunctions [function fname wptr_t (mgct [(aname,atype)]) [a_STD, a_FALIGNED] body']+    return fname++castFunc :: Op.ConvOp -> Op.Ty -> Op.Ty -> Expression -> Expression+castFunc co ta tb e | ta == tb = e+castFunc co _ Op.TyBool e = cast (basicType "bool") e+castFunc co Op.TyBool tb e = cast (opTyToC tb) e++castFunc Op.Lobits _ tb e = cast (opTyToC tb) e+castFunc Op.U2U _ tb e = cast (opTyToC tb) e+castFunc Op.Zx _ tb e = cast (opTyToC tb) e++castFunc Op.I2I tf tb e = cast (opTyToCh Op.HintSigned tb) (cast (opTyToCh Op.HintSigned tf) e)+castFunc Op.Sx tf tb e = cast (opTyToCh Op.HintSigned tb) (cast (opTyToCh Op.HintSigned tf) e)++castFunc Op.F2I tf tb e = cast (opTyToCh Op.HintSigned tb) e+castFunc Op.I2F tf tb e = cast (opTyToC tb) (cast (opTyToCh Op.HintSigned tf) e)++castFunc _ _ tb e = cast (opTyToC tb) e++----------------------------+-- c constants and utilities+----------------------------++gc_roots vs   = case length vs of+--    1 ->  functionCall (name "gc_frame1") (v_gc:vs)+--    2 ->  functionCall (name "gc_frame2") (v_gc:vs)+    lvs -> functionCall (name "gc_frame0") (v_gc:constant (number (fromIntegral lvs)):vs)+--gc_end        = functionCall (name "gc_end") []+tbsize sz = functionCall (name "TO_BLOCKS") [sz]++jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_array_alloc_atomic") [v_gc,nullPtr, sz, toExpression (0::Int)]+                     | otherwise = jhc_malloc nullPtr (0::Int) (sizeof sptr_t *# sz)++jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,ntn, tbsize sz, toExpression nptrs]+--    | fopts FO.Jgc =  functionCall (name "gc_alloc") [v_gc,tbsize sz, toExpression nptrs]+jhc_malloc _ 0 sz = functionCall (name "jhc_malloc_atomic") [sz]+jhc_malloc _ _ sz = functionCall (name "jhc_malloc") [sz]++jhc_malloc_ptrs sz | fopts FO.Jgc =  functionCall (name "gc_array_alloc") [v_gc, sz]+jhc_malloc_ptrs sz = functionCall (name "jhc_malloc") [sizeof sptr_t *# sz]++f_assert e    = functionCall (name "assert") [e]+f_FROM_SPTR e = functionCall (name "FROM_SPTR") [e]+f_NODEP e     = functionCall (name "NODEP") [e]+f_RAW_SET_F e  = functionCall (name "RAW_SET_F") [e]+f_RAW_SET_UF e = functionCall (name "RAW_SET_UF") [e]+f_RAW_GET_F e  = functionCall (name "RAW_GET_F") [e]+f_RAW_GET_UF e = functionCall (name "RAW_GET_UF") [e]+f_MKLAZY e     = functionCall (name "MKLAZY") [e]+f_TO_FPTR e    = functionCall (name "TO_FPTR") [e]+f_eval e      = functionCall (name "eval") (mgc [e])+f_gc_add_root e  = functionCall (name "gc_add_root") (mgc [e])+f_promote e   = functionCall (name "promote") [e]+f_PROMOTE e   = functionCall (name "PROMOTE") [e]+f_FETCH_TAG e = functionCall (name "FETCH_TAG") [e]+f_FETCH_RAW_TAG e = functionCall (name "FETCH_RAW_TAG") [e]+--f_FETCH_MEM_TAG e = functionCall (name "FETCH_MEM_TAG") [e]+f_SET_RAW_TAG e   = functionCall (name "SET_RAW_TAG") [e]+f_SET_MEM_TAG e v = functionCall (name "SET_MEM_TAG") [e,v]+f_demote e    = functionCall (name "demote") [e]+--f_follow e    = functionCall (name "follow") [e]+f_update x y  = functionCall (name "update") [x,y]++arg i = name $ 'a':show i++varName (V n) | n < 0 = name $ 'g':show (- n)+varName (V n) = name $ 'v':show n++nodeTagName :: Atom -> Name+nodeTagName a = toName (fromAtom a)+nodeFuncName :: Atom -> Name+nodeFuncName a = toName (fromAtom a)++sptr_t  = basicGCType "sptr_t"+uintptr_t = basicGCType "uintptr_t"+fptr_t  = basicGCType "fptr_t"+wptr_t  = basicGCType "wptr_t"+gc_t    = basicGCType "gc_t"+v_gc = variable (name "gc")+v_saved_gc = variable (name "saved_gc")++a_STD = Attribute "A_STD"+a_FALIGNED = Attribute "A_FALIGNED"+a_MALLOC = Attribute "A_MALLOC"++concrete :: Atom -> Expression -> Expression+concrete t e = cast (ptrType $ structType (nodeStructName t)) e++getHead :: Expression -> Expression+getHead e = project' (name "head") e++nodeTypePtr a = liftM ptrType (nodeType a)+nodeType a = return $ structType (nodeStructName a)+nodeStructName :: Atom -> Name+nodeStructName a = toName ('s':fromAtom a)+nodeCacheName a = toName ('c':fromAtom a)++bool b x y = if b then x else y++x =:: y = newTmpVar y x++basicType' :: ExtType -> Type+basicType' b = basicType (show b)+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Monoid Written where+    mempty = Written mempty mempty mempty mempty mempty mempty+    mappend (Written aa ab ac ad ae af) (Written aa' ab' ac' ad' ae' af') = Written (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')(mappend af af')++--  Imported from other files :-
+ drift_processed/C/Prims.hs view
@@ -0,0 +1,374 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/C/Prims.hs" #-}+{-# LANGUAGE OverloadedStrings #-}+module C.Prims where++import Data.Binary+import Data.Monoid(Monoid(..))+import Data.Typeable+import qualified Data.Set as Set++import Doc.DocLike+import Doc.PPrint+import PackedString+import StringTable.Atom+import qualified Cmm.Op as Op++import GHC.Exts++data CallConv = CCall | StdCall | CApi | Primitive | DotNet+    deriving(Eq,Ord,Show)+    {-! derive: Binary !-}++data Safety = Safe | Unsafe deriving(Eq,Ord,Show)+    {-! derive: Binary !-}++newtype ExtType = ExtType PackedString+    deriving(Binary,IsString,Eq,Ord)++instance Show ExtType where+    show (ExtType p) = unpackPS p++instance Show Requires where+    show (Requires s) = show (Set.toList s)++newtype Requires = Requires (Set.Set (CallConv,PackedString))+    deriving(Eq,Ord,Monoid,Binary)++data DotNetPrim = DotNetField | DotNetCtor | DotNetMethod+    deriving(Typeable, Eq, Ord, Show)+    {-! derive: Binary !-}++primReqs p = f p where+    f CConst {} = primRequires p+    f Func {} = primRequires p+    f IFunc {} = primRequires p+    f AddrOf {} = primRequires p+    f _ = mempty++data Prim =+    PrimPrim Atom -- Special primitive implemented in the compiler somehow.+    | CConst {+        primRequires :: Requires,+        primConst :: !PackedString+        }  -- C code which evaluates to a constant+    | Func {+        primRequires :: Requires,+        funcName :: !PackedString,+        primArgTypes :: [ExtType],+        primRetType :: ExtType,+	primRetArgs :: [ExtType],+        primSafety  :: Safety+        }   -- function call with C calling convention+    | IFunc {+        primRequires :: Requires,+        primArgTypes :: [ExtType],+        primRetType :: ExtType+        } -- indirect function call with C calling convention+    | AddrOf {+        primRequires :: Requires,+        primConst :: !PackedString -- address of linker name+        }+    | Peek { primArgTy :: Op.Ty }  -- read value from memory+    | Poke { primArgTy :: Op.Ty }  -- write value to memory+    | PrimTypeInfo {+        primArgTy :: Op.Ty,+        primRetTy :: Op.Ty,+        primTypeInfo :: !PrimTypeInfo+        }+    | PrimString !PackedString  -- address of a raw string. encoded in utf8.+    | PrimDotNet {+        primStatic :: !Bool,+        primDotNet :: !DotNetPrim,+        primIOLike :: !Bool,+        primAssembly :: !PackedString,+        primDotNetName :: !PackedString+        }+    | Op {+        primCOp :: Op.Op Op.Ty,+        primRetTy :: Op.Ty+        }+    deriving(Typeable, Eq, Ord, Show)+    {-! derive: Binary !-}++data PrimTypeInfo = PrimSizeOf | PrimMaxBound | PrimMinBound | PrimAlignmentOf | PrimUMaxBound+    deriving(Typeable, Eq, Ord, Show)+    {-! derive: Binary !-}++primStaticTypeInfo :: Op.Ty -> PrimTypeInfo -> Maybe Integer+primStaticTypeInfo (Op.TyBits (Op.Bits b) _) w = Just ans where+    bits = toInteger b+    ans = case w of+        PrimSizeOf -> bits `div` 8+        PrimAlignmentOf ->  bits `div` 8+        PrimMinBound -> negate $ 2^(bits - 1)+        PrimMaxBound -> 2^(bits - 1) - 1+        PrimUMaxBound -> 2^bits - 1+primStaticTypeInfo _ _ = Nothing++-- | These primitives may safely be duplicated without affecting performance or+-- correctness too adversly. either because they are cheap to begin with, or+-- will be recombined in a later pass.++primIsCheap :: Prim -> Bool+primIsCheap AddrOf {} = True+primIsCheap CConst {} = True+primIsCheap PrimString {} = True+primIsCheap PrimTypeInfo {} = True+primIsCheap Op { primCOp = op } = Op.isCheap op+primIsCheap _ = False++-- | whether a primitive represents a constant expression (assuming all its arguments are constant)+-- TODO needs grin support+primIsConstant :: Prim -> Bool+primIsConstant CConst {} = True+primIsConstant AddrOf {} = True+primIsConstant PrimString {} = True+primIsConstant PrimTypeInfo {} = True+primIsConstant Op { primCOp = op } = Op.isEagerSafe op+primIsConstant _ = False++-- | whether a primitive can be eagarly evaluated.+-- TODO needs grin support+primEagerSafe :: Prim -> Bool+primEagerSafe CConst {} = True+primEagerSafe PrimString {} = True+primEagerSafe AddrOf {} = True+primEagerSafe PrimTypeInfo {} = True+primEagerSafe Op { primCOp = op } = Op.isEagerSafe op+primEagerSafe _ = False++primPrim s = PrimPrim $ toAtom s++instance DocLike d => PPrint d ExtType where+    pprint t = tshow t+--instance DocLike d => PPrint d PackedString where+--    pprint t = text $ unpackPS t++instance DocLike d => PPrint d Prim where+    pprint (PrimPrim t) = text (fromAtom t)+    pprint (CConst _ s) = parens (text $ unpackPS s)+    pprint Func { .. } = parens (tshow primRetType) <> text (unpackPS funcName) <> tupled (map pprint primArgTypes)+    pprint IFunc { .. } = parens (tshow primRetType) <> parens (char '*') <> tupled (map pprint primArgTypes)+    pprint (AddrOf _ s) = char '&' <> text (unpackPS s)+    pprint (PrimString s) = tshow s <> char '#'+    pprint (Peek t) = char '*' <> tshow t+    pprint (Poke t) = char '=' <> tshow t+    pprint Op { primCOp = Op.BinOp bo ta tb, primRetTy = rt } | rt == ta && rt == tb = parens (pprint rt) <> tshow bo+    pprint Op { primCOp = Op.UnOp bo ta, primRetTy = rt } | rt == ta = parens (pprint rt) <> tshow bo+    pprint Op { primCOp = op, primRetTy = rt } = parens (pprint rt) <> pprint op+    pprint PrimDotNet { primDotNet = dn,  primDotNetName = nn} = parens (text (unpackPS nn))+    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimSizeOf } = text "sizeof" <> parens (tshow at)+    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimAlignmentOf } = text "alignmentof" <> parens (tshow at)+    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMaxBound } = text "max" <> parens (tshow at)+    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimUMaxBound } = text "umax" <> parens (tshow at)+    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMinBound } = text "min" <> parens (tshow at)++instance DocLike d => PPrint d Op.Ty where+    pprintAssoc _ n p = text (showsPrec n p "")+instance (DocLike d,Show v) => PPrint d (Op.Op v) where+    pprintAssoc _ n p = text (showsPrec n p "")++parseDotNetFFI :: Monad m => String -> m Prim+parseDotNetFFI s = ans where+    init = PrimDotNet { primIOLike = False, primStatic = False, primDotNet = DotNetField, primAssembly = packString "", primDotNetName = packString "" }+    ans = case words s of+        ("static":rs) -> f rs init { primStatic = True }+        rs -> f rs init+    f ("field":rs) dn = g dn { primDotNet = DotNetField } rs+    f ("ctor":rs) dn = g dn { primDotNet = DotNetCtor } rs+    f ("method":rs) dn = g dn { primDotNet = DotNetMethod } rs+    f _ _ = fail "invalid .NET ffi specification"+    g dn ['[':rs] | (as,']':nm) <- span (/= ']') rs = return dn { primAssembly = packString as, primDotNetName = packString nm }+    g dn [n] = return dn { primDotNetName = packString n }+    g _ _ = fail "invalid .NET ffi specification"+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary CallConv where+    put CCall = do+	    Data.Binary.putWord8 0+    put StdCall = do+	    Data.Binary.putWord8 1+    put CApi = do+	    Data.Binary.putWord8 2+    put Primitive = do+	    Data.Binary.putWord8 3+    put DotNet = do+	    Data.Binary.putWord8 4+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return CCall+	      1 -> do+		    return StdCall+	      2 -> do+		    return CApi+	      3 -> do+		    return Primitive+	      4 -> do+		    return DotNet+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Safety where+    put Safe = do+	    Data.Binary.putWord8 0+    put Unsafe = do+	    Data.Binary.putWord8 1+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Safe+	      1 -> do+		    return Unsafe+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary DotNetPrim where+    put DotNetField = do+	    Data.Binary.putWord8 0+    put DotNetCtor = do+	    Data.Binary.putWord8 1+    put DotNetMethod = do+	    Data.Binary.putWord8 2+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return DotNetField+	      1 -> do+		    return DotNetCtor+	      2 -> do+		    return DotNetMethod+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Prim where+    put (PrimPrim aa) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+    put (CConst ab ac) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ab+	    Data.Binary.put ac+    put (Func ad ae af ag ah ai) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ad+	    Data.Binary.put ae+	    Data.Binary.put af+	    Data.Binary.put ag+	    Data.Binary.put ah+	    Data.Binary.put ai+    put (IFunc aj ak al) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put aj+	    Data.Binary.put ak+	    Data.Binary.put al+    put (AddrOf am an) = do+	    Data.Binary.putWord8 4+	    Data.Binary.put am+	    Data.Binary.put an+    put (Peek ao) = do+	    Data.Binary.putWord8 5+	    Data.Binary.put ao+    put (Poke ap) = do+	    Data.Binary.putWord8 6+	    Data.Binary.put ap+    put (PrimTypeInfo aq ar as) = do+	    Data.Binary.putWord8 7+	    Data.Binary.put aq+	    Data.Binary.put ar+	    Data.Binary.put as+    put (PrimString at) = do+	    Data.Binary.putWord8 8+	    Data.Binary.put at+    put (PrimDotNet au av aw ax ay) = do+	    Data.Binary.putWord8 9+	    Data.Binary.put au+	    Data.Binary.put av+	    Data.Binary.put aw+	    Data.Binary.put ax+	    Data.Binary.put ay+    put (Op az aA) = do+	    Data.Binary.putWord8 10+	    Data.Binary.put az+	    Data.Binary.put aA+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    return (PrimPrim aa)+	      1 -> do+		    ab <- Data.Binary.get+		    ac <- Data.Binary.get+		    return (CConst ab ac)+	      2 -> do+		    ad <- Data.Binary.get+		    ae <- Data.Binary.get+		    af <- Data.Binary.get+		    ag <- Data.Binary.get+		    ah <- Data.Binary.get+		    ai <- Data.Binary.get+		    return (Func ad ae af ag ah ai)+	      3 -> do+		    aj <- Data.Binary.get+		    ak <- Data.Binary.get+		    al <- Data.Binary.get+		    return (IFunc aj ak al)+	      4 -> do+		    am <- Data.Binary.get+		    an <- Data.Binary.get+		    return (AddrOf am an)+	      5 -> do+		    ao <- Data.Binary.get+		    return (Peek ao)+	      6 -> do+		    ap <- Data.Binary.get+		    return (Poke ap)+	      7 -> do+		    aq <- Data.Binary.get+		    ar <- Data.Binary.get+		    as <- Data.Binary.get+		    return (PrimTypeInfo aq ar as)+	      8 -> do+		    at <- Data.Binary.get+		    return (PrimString at)+	      9 -> do+		    au <- Data.Binary.get+		    av <- Data.Binary.get+		    aw <- Data.Binary.get+		    ax <- Data.Binary.get+		    ay <- Data.Binary.get+		    return (PrimDotNet au av aw ax ay)+	      10 -> do+		    az <- Data.Binary.get+		    aA <- Data.Binary.get+		    return (Op az aA)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary PrimTypeInfo where+    put PrimSizeOf = do+	    Data.Binary.putWord8 0+    put PrimMaxBound = do+	    Data.Binary.putWord8 1+    put PrimMinBound = do+	    Data.Binary.putWord8 2+    put PrimAlignmentOf = do+	    Data.Binary.putWord8 3+    put PrimUMaxBound = do+	    Data.Binary.putWord8 4+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return PrimSizeOf+	      1 -> do+		    return PrimMaxBound+	      2 -> do+		    return PrimMinBound+	      3 -> do+		    return PrimAlignmentOf+	      4 -> do+		    return PrimUMaxBound+	      _ -> fail "invalid binary data found"++--  Imported from other files :-
+ drift_processed/Cmm/Op.hs view
@@ -0,0 +1,894 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/Cmm/Op.hs" #-}+{-# OPTIONS -funbox-strict-fields #-}+module Cmm.Op where++import Data.Binary+import Util.Gen+import Text.ParserCombinators.ReadP as P+import Text.Read.Lex++{-++Basic operations. These are chosen to be roughly equivalent to c-- operations,+but can be effectively used to generate C or assembly code as well.++An operation consists of the operation itself, the type of the arguments and+return value, and a hint attached to each argument.++A condition is that the operation must be fully determined by the operation+name and the type of its arguments. this specifically does not include the+hint. For instance, since whether a number is signed or unsigned is in the+hint, so the operation itself must say whether it is signed or unsigned.++Also, distinct algorithms should be given different operations, for instance+floating point and integer comparison are so different that they should be+separate opcodes, even if it could be determined by the type they operate on.++-}++-- these take 2 arguments of the same type, and return one of the same type.+-- an exception are the mulx routines, which may return a type exactly+-- double in size of the original, and the shift and rotate routines, where the+-- second argument may be of any width and is interpreted as an unsigned+-- number.+--+-- the invarient is that the return type is always exactly determined by the+-- argument types++data BinOp+    = Add+    | Sub++    | Mul+    | Mulx+    | UMulx++    | Div   -- ^ round to -Infinity+    | Mod   -- ^ mod rounding to -Infinity++    | Quot  -- ^ round to 0+    | Rem   -- ^ rem rounding to 0++    | UDiv  -- ^ round to zero (unsigned)+    | UMod  -- ^ unsigned mod++    -- bitwise+    | And+    | Or+    | Xor+    | Shl+    | Shr    -- ^ shift right logical+    | Shra   -- ^ shift right arithmetic+    | Rotl+    | Rotr++    -- floating+    | FAdd+    | FSub+    | FDiv+    | FMul+    | FPwr+    | FAtan2++    -- These all compare two things of the same type, and return a boolean.+    | Eq+    | NEq+    | Gt+    | Gte+    | Lt+    | Lte+    -- unsigned versions+    | UGt+    | UGte+    | ULt+    | ULte++    -- floating point comparasons+    | FEq+    | FNEq+    | FGt+    | FGte+    | FLt+    | FLte+    -- whether two values can be compared at all.+    | FOrdered+    deriving(Eq,Show,Ord,Read,Enum,Bounded)+    {-! derive: Binary !-}++data UnOp+    = Neg   -- ^ 2s compliment negation+    | Com   -- ^ bitwise compliment+    -- floating+    | FAbs  -- ^ floating absolute value+    | FNeg  -- ^ floating point negation+    | Sin+    | Cos+    | Tan+    | Sinh+    | Cosh+    | Tanh+    | Asin+    | Acos+    | Atan+    | Log+    | Exp+    | Sqrt+    -- exotic bit operations+    | Bswap  -- ^ Switch the order of the bytes in a word+    | Ffs    -- ^ Returns one plus the index of the least+             --   significant 1-bit of x, 0 if x is zero.+    | Clz    -- ^ number of leading (from MSB) zeros, undefined if zero+    | Ctz    -- ^ number of trailing (from LSB) zeros, undefined if zero.+    | Popcount -- ^ number of bits set to 1 in word+    | Parity   -- ^ number of bits set to 1 mod 2+    deriving(Eq,Show,Ord,Read,Enum,Bounded)+    {-! derive: Binary !-}++-- conversion ops++data ConvOp+    = F2I         -- ^ convert a floating point to an integral value via truncation+    | F2U         -- ^ convert a floating point to an unsigned integral value via truncation, negative values become zero+    | U2F         -- ^ convert an unsigned integral value to a floating point number+    | I2F         -- ^ convert an integral value to a floating point number+    | F2F         -- ^ convert a float from one precision to another, preserving value as much as possible+    | Lobits      -- ^ extract the low order bits+    | Sx          -- ^ sign extend a value (signed)+    | Zx          -- ^ zero extend a value (unsigned)+    | I2I         -- ^ perform a 'Lobits' or a 'Sx' depending on the sizes of the arguments+    | U2U         -- ^ perform a 'Lobits' or a 'Zx' depending on the sizes of the arguments+    | B2B         -- ^ a nop, useful for coercing hints (bits 2 bits)+    deriving(Eq,Show,Ord,Read,Enum,Bounded)+    {-! derive: Binary !-}++data ValOp+    = NaN+    | PInf+    | NInf+    | PZero+    | NZero+    deriving(Eq,Show,Ord,Read,Bounded)+    {-! derive: Binary !-}++data ArchBits = BitsMax | BitsPtr | BitsUnknown+    deriving(Eq,Ord)+    {-! derive: Binary !-}++data TyBits = Bits {-# UNPACK #-} !Int | BitsArch !ArchBits |  BitsExt String+    deriving(Eq,Ord)+    {-! derive: Binary !-}++data TyHint+    = HintSigned+    | HintUnsigned+    | HintFloat        -- an IEEE floating point value+    | HintCharacter    -- a unicode character, implies unsigned+    | HintNone         -- no hint+    deriving(Eq,Ord)+    {-! derive: Binary !-}++data Ty+    = TyBits !TyBits !TyHint+    | TyBool+    | TyComplex Ty+    | TyVector !Int Ty+    deriving(Eq,Ord)+    {-! derive: Binary !-}++--runReadP :: ReadP a -> String -> Maybe a+--runReadP rp s = case readP_to_S rp s of+--    [(x,"")] -> Just x+--    _ -> Nothing++preadTy :: ReadP Ty+preadTy = choice cs where+    cs = [ do string "bool"; return TyBool+         , do char 's'; TyBits x _ <- preadTy; return $ TyBits x HintSigned+         , do char 'u'; TyBits x _ <- preadTy; return $ TyBits x HintUnsigned+         , do char 'f'; TyBits x _ <- preadTy; return $ TyBits x HintFloat+         , do char 'c'; TyBits x _ <- preadTy; return $ TyBits x HintCharacter+         , do string "bits<"; x <- manyTill P.get (char '>'); return $ TyBits (f x) HintNone+         , do string "bits"; x <- readDecP; return $ TyBits (Bits x) HintNone+         , do n <- readDecP; char '*'; t <- preadTy; return (TyVector n t)+         , do string "i"; t <- preadTy; return (TyComplex t)+         ]+    f "ptr" = BitsArch BitsPtr+    f "max" = BitsArch BitsMax+    f "?"   = BitsArch BitsUnknown+    f x     = BitsExt x++readTy :: Monad m => String -> m Ty+readTy s = case runReadP preadTy s of+    Nothing -> fail "readTy: not type"+    Just x -> return x++stringToOpTy ::  String -> Ty+stringToOpTy s = case readTy s of+    Just t -> t+    _ -> error $ "stringToOpTy: " ++ show s++bool = TyBool+bits_ptr = TyBits (BitsArch BitsPtr) HintNone+bits_max = TyBits (BitsArch BitsMax) HintNone+bits8    = TyBits (Bits 8)  HintNone+bits16   = TyBits (Bits 16) HintNone+bits32   = TyBits (Bits 32) HintNone+bits64   = TyBits (Bits 64) HintNone++class ToCmmTy a where+    toCmmTy :: a -> Maybe Ty++instance ToCmmTy Ty where+    toCmmTy a = Just a++instance ToCmmTy String where+    toCmmTy s = readTy s++cmmTyBits :: ToCmmTy a => a -> Maybe Int+cmmTyBits x = do TyBits (Bits b) _ <- toCmmTy x; return b+cmmTyHint x = do TyBits _ hint <- toCmmTy x; return hint++instance Show TyHint where+    showsPrec _ HintSigned = ('s':)+    showsPrec _ HintUnsigned = ('u':)+    showsPrec _ HintFloat = ('f':)+    showsPrec _ HintCharacter = ('c':)+    showsPrec _ HintNone = id++instance Show Ty where+    showsPrec _ TyBool = showString "bool"+    showsPrec _ (TyBits b h) = shows h . showString "bits" . shows b+    showsPrec _ (TyVector n t) = shows n . showChar '*' . shows t+    showsPrec _ (TyComplex t) = showChar 'i' . shows t++instance Show TyBits where+    showsPrec _ (Bits n) = shows n+    showsPrec _ (BitsExt s) = showChar '<' . showString s . showChar '>'+    showsPrec _ (BitsArch s) = showChar '<' . shows s . showChar '>'++instance Show ArchBits where+    show BitsMax = "max"+    show BitsPtr = "ptr"+    show BitsUnknown = "?"++data Op v+    = BinOp BinOp v v+    | UnOp UnOp v+    | ValOp ValOp+    | ConvOp ConvOp v+    deriving(Eq,Show,Ord)+    {-! derive: Binary !-}++binopType :: BinOp -> Ty -> Ty -> Ty+binopType Mulx  (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h+binopType UMulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h+binopType Eq  _ _ =  TyBool+binopType NEq _ _ =  TyBool+binopType Gt  _ _ =  TyBool+binopType Gte _ _ =  TyBool+binopType Lt  _ _ =  TyBool+binopType Lte _ _ =  TyBool+binopType UGt  _ _ =  TyBool+binopType UGte _ _ =  TyBool+binopType ULt  _ _ =  TyBool+binopType ULte _ _ =  TyBool+binopType FEq  _ _ =  TyBool+binopType FNEq _ _ =  TyBool+binopType FGt  _ _ =  TyBool+binopType FGte _ _ =  TyBool+binopType FLt  _ _ =  TyBool+binopType FLte _ _ =  TyBool+binopType FOrdered _ _ =  TyBool+binopType _ t1 _ = t1++isCommutable :: BinOp -> Bool+isCommutable x = f x where+    f Add = True+    f Mul = True+    f And = True+    f Or  = True+    f Xor = True+    f Eq  = True+    f NEq = True+    f FAdd = True+    f FMul = True+    f FEq  = True+    f FNEq = True+    f FOrdered = True+    f _ = False++commuteBinOp :: BinOp -> Maybe BinOp+commuteBinOp x | isCommutable x = return x+commuteBinOp Lt = return Gt+commuteBinOp Gt = return Lt+commuteBinOp Lte = return Gte+commuteBinOp Gte = return Lte+commuteBinOp ULt = return UGt+commuteBinOp UGt = return ULt+commuteBinOp ULte = return UGte+commuteBinOp UGte = return ULte+commuteBinOp FLt = return FGt+commuteBinOp FGt = return FLt+commuteBinOp FLte = return FGte+commuteBinOp FGte = return FLte+commuteBinOp _ = Nothing++isAssociative :: BinOp -> Bool+isAssociative x = f x where+    f Add = True+    f Mul = True+    f And = True+    f Or  = True+    f Xor = True+    f _ = False++unopFloat :: Ty -> UnOp -> Maybe String+unopFloat (TyBits b HintFloat) op = g b =<< f op where+    g (Bits 64) x = return x+    g (Bits 32) x = return $ x ++ "f"+    g _ _ = Nothing+    f FAbs = return "fabs"+    f Sin  = return "sin"+    f Cos  = return "cos"+    f Tan  = return "tan"+    f Sinh  = return "sinh"+    f Cosh  = return "cosh"+    f Tanh  = return "tanh"+    f Asin  = return "asin"+    f Acos  = return "acos"+    f Atan  = return "atan"+    f Sqrt = return "sqrt"+    f Log = return "log"+    f Exp = return "exp"++    f _ = Nothing+unopFloat _ _ = Nothing++binopFunc :: Ty -> Ty -> BinOp -> Maybe String+binopFunc (TyBits b _) _ bop = g b =<< f bop where+    g (Bits 64) x = return x+    g (Bits 32) x = return $ x ++ "f"+    g _ _ = Nothing+    f FPwr = Just "pow"+    f FAtan2 = Just "atan2"+    f _ = Nothing+binopFunc TyBool _ bop = Nothing+binopFunc _ _ _ = error "Op.binopFunc: bad."++binopInfix :: BinOp -> Maybe (String,Int)+binopInfix UDiv = Just ("/",8)+binopInfix Mul  = Just ("*",8)+binopInfix UMod = Just ("%",8)+binopInfix Sub  = Just ("-",7)+binopInfix Add  = Just ("+",7)+binopInfix Shr  = Just (">>",6)+binopInfix Shl  = Just ("<<",6)+binopInfix And  = Just ("&",5)+binopInfix Xor  = Just ("^",4)+binopInfix Or   = Just ("|",3)+binopInfix UGte = Just (">=",2)+binopInfix UGt  = Just (">",2)+binopInfix ULte = Just ("<=",2)+binopInfix ULt  = Just ("<",2)+binopInfix Eq   = Just ("==",2)+binopInfix NEq  = Just ("!=",2)+binopInfix _ = Nothing++class IsOperator o where+    isCheap :: o -> Bool+    isEagerSafe :: o -> Bool++instance IsOperator BinOp where+    isCheap FAtan2 = False+    isCheap _ = True++    isEagerSafe Div = False+    isEagerSafe Mod = False+    isEagerSafe Quot = False+    isEagerSafe Rem  = False+    isEagerSafe UDiv = False+    isEagerSafe UMod = False+    isEagerSafe _ = True++instance IsOperator UnOp where+    isCheap _ = True+    isEagerSafe _ = True++instance IsOperator ConvOp where+    isCheap _ = True+    isEagerSafe _ = True++instance IsOperator (Op v) where+    isCheap (BinOp o _ _) = isCheap o+    isCheap (UnOp o _) = isCheap o+    isCheap (ConvOp o _) = isCheap o+    isCheap _ = False+    isEagerSafe (BinOp o _ _) = isEagerSafe o+    isEagerSafe (UnOp o _) = isEagerSafe o+    isEagerSafe (ConvOp o _) = isEagerSafe o+    isEagerSafe _ = False+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary BinOp where+    put Add = do+	    Data.Binary.putWord8 0+    put Sub = do+	    Data.Binary.putWord8 1+    put Mul = do+	    Data.Binary.putWord8 2+    put Mulx = do+	    Data.Binary.putWord8 3+    put UMulx = do+	    Data.Binary.putWord8 4+    put Div = do+	    Data.Binary.putWord8 5+    put Mod = do+	    Data.Binary.putWord8 6+    put Quot = do+	    Data.Binary.putWord8 7+    put Rem = do+	    Data.Binary.putWord8 8+    put UDiv = do+	    Data.Binary.putWord8 9+    put UMod = do+	    Data.Binary.putWord8 10+    put And = do+	    Data.Binary.putWord8 11+    put Or = do+	    Data.Binary.putWord8 12+    put Xor = do+	    Data.Binary.putWord8 13+    put Shl = do+	    Data.Binary.putWord8 14+    put Shr = do+	    Data.Binary.putWord8 15+    put Shra = do+	    Data.Binary.putWord8 16+    put Rotl = do+	    Data.Binary.putWord8 17+    put Rotr = do+	    Data.Binary.putWord8 18+    put FAdd = do+	    Data.Binary.putWord8 19+    put FSub = do+	    Data.Binary.putWord8 20+    put FDiv = do+	    Data.Binary.putWord8 21+    put FMul = do+	    Data.Binary.putWord8 22+    put FPwr = do+	    Data.Binary.putWord8 23+    put FAtan2 = do+	    Data.Binary.putWord8 24+    put Eq = do+	    Data.Binary.putWord8 25+    put NEq = do+	    Data.Binary.putWord8 26+    put Gt = do+	    Data.Binary.putWord8 27+    put Gte = do+	    Data.Binary.putWord8 28+    put Lt = do+	    Data.Binary.putWord8 29+    put Lte = do+	    Data.Binary.putWord8 30+    put UGt = do+	    Data.Binary.putWord8 31+    put UGte = do+	    Data.Binary.putWord8 32+    put ULt = do+	    Data.Binary.putWord8 33+    put ULte = do+	    Data.Binary.putWord8 34+    put FEq = do+	    Data.Binary.putWord8 35+    put FNEq = do+	    Data.Binary.putWord8 36+    put FGt = do+	    Data.Binary.putWord8 37+    put FGte = do+	    Data.Binary.putWord8 38+    put FLt = do+	    Data.Binary.putWord8 39+    put FLte = do+	    Data.Binary.putWord8 40+    put FOrdered = do+	    Data.Binary.putWord8 41+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Add+	      1 -> do+		    return Sub+	      2 -> do+		    return Mul+	      3 -> do+		    return Mulx+	      4 -> do+		    return UMulx+	      5 -> do+		    return Div+	      6 -> do+		    return Mod+	      7 -> do+		    return Quot+	      8 -> do+		    return Rem+	      9 -> do+		    return UDiv+	      10 -> do+		    return UMod+	      11 -> do+		    return And+	      12 -> do+		    return Or+	      13 -> do+		    return Xor+	      14 -> do+		    return Shl+	      15 -> do+		    return Shr+	      16 -> do+		    return Shra+	      17 -> do+		    return Rotl+	      18 -> do+		    return Rotr+	      19 -> do+		    return FAdd+	      20 -> do+		    return FSub+	      21 -> do+		    return FDiv+	      22 -> do+		    return FMul+	      23 -> do+		    return FPwr+	      24 -> do+		    return FAtan2+	      25 -> do+		    return Eq+	      26 -> do+		    return NEq+	      27 -> do+		    return Gt+	      28 -> do+		    return Gte+	      29 -> do+		    return Lt+	      30 -> do+		    return Lte+	      31 -> do+		    return UGt+	      32 -> do+		    return UGte+	      33 -> do+		    return ULt+	      34 -> do+		    return ULte+	      35 -> do+		    return FEq+	      36 -> do+		    return FNEq+	      37 -> do+		    return FGt+	      38 -> do+		    return FGte+	      39 -> do+		    return FLt+	      40 -> do+		    return FLte+	      41 -> do+		    return FOrdered+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary UnOp where+    put Neg = do+	    Data.Binary.putWord8 0+    put Com = do+	    Data.Binary.putWord8 1+    put FAbs = do+	    Data.Binary.putWord8 2+    put FNeg = do+	    Data.Binary.putWord8 3+    put Sin = do+	    Data.Binary.putWord8 4+    put Cos = do+	    Data.Binary.putWord8 5+    put Tan = do+	    Data.Binary.putWord8 6+    put Sinh = do+	    Data.Binary.putWord8 7+    put Cosh = do+	    Data.Binary.putWord8 8+    put Tanh = do+	    Data.Binary.putWord8 9+    put Asin = do+	    Data.Binary.putWord8 10+    put Acos = do+	    Data.Binary.putWord8 11+    put Atan = do+	    Data.Binary.putWord8 12+    put Log = do+	    Data.Binary.putWord8 13+    put Exp = do+	    Data.Binary.putWord8 14+    put Sqrt = do+	    Data.Binary.putWord8 15+    put Bswap = do+	    Data.Binary.putWord8 16+    put Ffs = do+	    Data.Binary.putWord8 17+    put Clz = do+	    Data.Binary.putWord8 18+    put Ctz = do+	    Data.Binary.putWord8 19+    put Popcount = do+	    Data.Binary.putWord8 20+    put Parity = do+	    Data.Binary.putWord8 21+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Neg+	      1 -> do+		    return Com+	      2 -> do+		    return FAbs+	      3 -> do+		    return FNeg+	      4 -> do+		    return Sin+	      5 -> do+		    return Cos+	      6 -> do+		    return Tan+	      7 -> do+		    return Sinh+	      8 -> do+		    return Cosh+	      9 -> do+		    return Tanh+	      10 -> do+		    return Asin+	      11 -> do+		    return Acos+	      12 -> do+		    return Atan+	      13 -> do+		    return Log+	      14 -> do+		    return Exp+	      15 -> do+		    return Sqrt+	      16 -> do+		    return Bswap+	      17 -> do+		    return Ffs+	      18 -> do+		    return Clz+	      19 -> do+		    return Ctz+	      20 -> do+		    return Popcount+	      21 -> do+		    return Parity+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary ConvOp where+    put F2I = do+	    Data.Binary.putWord8 0+    put F2U = do+	    Data.Binary.putWord8 1+    put U2F = do+	    Data.Binary.putWord8 2+    put I2F = do+	    Data.Binary.putWord8 3+    put F2F = do+	    Data.Binary.putWord8 4+    put Lobits = do+	    Data.Binary.putWord8 5+    put Sx = do+	    Data.Binary.putWord8 6+    put Zx = do+	    Data.Binary.putWord8 7+    put I2I = do+	    Data.Binary.putWord8 8+    put U2U = do+	    Data.Binary.putWord8 9+    put B2B = do+	    Data.Binary.putWord8 10+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return F2I+	      1 -> do+		    return F2U+	      2 -> do+		    return U2F+	      3 -> do+		    return I2F+	      4 -> do+		    return F2F+	      5 -> do+		    return Lobits+	      6 -> do+		    return Sx+	      7 -> do+		    return Zx+	      8 -> do+		    return I2I+	      9 -> do+		    return U2U+	      10 -> do+		    return B2B+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary ValOp where+    put NaN = do+	    Data.Binary.putWord8 0+    put PInf = do+	    Data.Binary.putWord8 1+    put NInf = do+	    Data.Binary.putWord8 2+    put PZero = do+	    Data.Binary.putWord8 3+    put NZero = do+	    Data.Binary.putWord8 4+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return NaN+	      1 -> do+		    return PInf+	      2 -> do+		    return NInf+	      3 -> do+		    return PZero+	      4 -> do+		    return NZero+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary ArchBits where+    put BitsMax = do+	    Data.Binary.putWord8 0+    put BitsPtr = do+	    Data.Binary.putWord8 1+    put BitsUnknown = do+	    Data.Binary.putWord8 2+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return BitsMax+	      1 -> do+		    return BitsPtr+	      2 -> do+		    return BitsUnknown+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary TyBits where+    put (Bits aa) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+    put (BitsArch ab) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ab+    put (BitsExt ac) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ac+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    return (Bits aa)+	      1 -> do+		    ab <- Data.Binary.get+		    return (BitsArch ab)+	      2 -> do+		    ac <- Data.Binary.get+		    return (BitsExt ac)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary TyHint where+    put HintSigned = do+	    Data.Binary.putWord8 0+    put HintUnsigned = do+	    Data.Binary.putWord8 1+    put HintFloat = do+	    Data.Binary.putWord8 2+    put HintCharacter = do+	    Data.Binary.putWord8 3+    put HintNone = do+	    Data.Binary.putWord8 4+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return HintSigned+	      1 -> do+		    return HintUnsigned+	      2 -> do+		    return HintFloat+	      3 -> do+		    return HintCharacter+	      4 -> do+		    return HintNone+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Ty where+    put (TyBits aa ab) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+    put TyBool = do+	    Data.Binary.putWord8 1+    put (TyComplex ac) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ac+    put (TyVector ad ae) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ad+	    Data.Binary.put ae+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    return (TyBits aa ab)+	      1 -> do+		    return TyBool+	      2 -> do+		    ac <- Data.Binary.get+		    return (TyComplex ac)+	      3 -> do+		    ad <- Data.Binary.get+		    ae <- Data.Binary.get+		    return (TyVector ad ae)+	      _ -> fail "invalid binary data found"++instance (Data.Binary.Binary v) => Data.Binary.Binary (Op v) where+    put (BinOp aa ab ac) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+    put (UnOp ad ae) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ad+	    Data.Binary.put ae+    put (ValOp af) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put af+    put (ConvOp ag ah) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ag+	    Data.Binary.put ah+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    ac <- Data.Binary.get+		    return (BinOp aa ab ac)+	      1 -> do+		    ad <- Data.Binary.get+		    ae <- Data.Binary.get+		    return (UnOp ad ae)+	      2 -> do+		    af <- Data.Binary.get+		    return (ValOp af)+	      3 -> do+		    ag <- Data.Binary.get+		    ah <- Data.Binary.get+		    return (ConvOp ag ah)+	      _ -> fail "invalid binary data found"++--  Imported from other files :-
+ drift_processed/DataConstructors.hs view
@@ -0,0 +1,1027 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/DataConstructors.hs" #-}+{-# LANGUAGE OverloadedStrings #-}+module DataConstructors(+    AliasType(..),+    boxPrimitive,+    collectDeriving,+    conSlots,+    constructionExpression,+    Constructor(..),+    DataFamily(..),+    DataTable(..),+    DataTableMonad(..),+    dataTablePrims,+    deconstructionExpression,+    deriveClasses,+    extractIO,+    extractIO',+    extractPrimitive,+    ExtTypeInfo(..),+    extTypeInfoExtType,+    followAlias,+    followAliases,+    getConstructor,+    getConstructorArities,+    getProduct,+    getSiblings,+    lookupExtTypeInfo,+    mktBox,+    modBox,+    numberSiblings,+    onlyChild,+    pprintTypeOfCons,+    primitiveAliases,+    removeNewtypes,+    samplePrimitiveDataTable,+    showDataTable,+    Slot(..),+    slotTypes,+    slotTypesHs,+    tAbsurd,+    toDataTable,+    typesCompatable,+    updateLit+    ) where++import Control.Monad.Identity+import Control.Monad.Writer(tell,execWriter)+import Data.Maybe+import Data.Monoid hiding(getProduct)+import Data.List(sortBy)+import qualified Data.Map as Map hiding(map)+import qualified Data.Set as Set hiding(map)++import C.Prims+import Data.Binary+import Doc.DocLike as D+import Doc.PPrint+import Doc.Pretty+import E.Binary()+import E.E+import E.Show+import E.Subst+import E.Traverse+import E.TypeCheck+import E.Values+import FrontEnd.Class(instanceName)+import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse+import FrontEnd.Tc.Type+import GenUtil+import Info.Types+import Name.Id+import Name.Name as Name+import Name.Names+import Name.VConsts+import PackedString+import Support.CanType+import Support.FreeVars+import Support.MapBinaryInstance+import Support.Unparse+import Util.HasSize+import Util.SameShape+import Util.SetLike as S+import Util.VarName+import qualified Cmm.Op as Op+import qualified Util.Graph as G+import qualified Util.Seq as Seq++tipe' (TAp t1 t2) = liftM2 eAp (tipe' t1) (tipe' t2)+tipe' (TArrow t1 t2) =  do+    t1' <- tipe' t1+    t2' <- tipe' t2+    return $ EPi (tVr emptyId (t1')) t2'+tipe' (TCon (Tycon n k)) | Just n' <- Map.lookup n primitiveAliases = return $ ELit litCons { litName = n', litType = kind k }+tipe' (TCon (Tycon n k)) =  return $ ELit litCons { litName = n, litType = kind k }+tipe' (TVar tv@Tyvar { tyvarKind = k}) = do+    v <- lookupName tv+    return $ EVar $ tVr v (kind k)+tipe' (TForAll [] (_ :=> t)) = tipe' t+tipe' (TExists [] (_ :=> t)) = tipe' t+tipe' (TForAll xs (_ :=> t)) = do+    xs' <- flip mapM xs $ \tv -> do+        v <- newName (map anonymous [35 .. ]) () tv+        return $ tVr v (kind $ tyvarKind tv)+    t' <- tipe' t+    return $ foldr EPi t' xs' -- [ tVr n (kind k) | n <- [2,4..] | k <- xs ]+tipe' ~(TExists xs (_ :=> t)) = do+    xs' <- flip mapM xs $ \tv -> do+        --v <- newName [70,72..] () tv+        --return $ tVr v (kind $ tyvarKind tv)+        return $ (kind $ tyvarKind tv)+    t' <- tipe' t+    return $ ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = (t':xs'), litType = eHash }++kind (KBase KUTuple) = eHash+kind (KBase KHash) = eHash+kind (KBase Star) = eStar+kind (KBase (KNamed t)) = ESort (ESortNamed t)+kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2)+kind k = error $ "DataConstructors.kind: cannot convert " ++ show k++data AliasType = ErasedAlias | RecursiveAlias+    deriving(Eq,Ord,Show)+    {-! derive: Binary !-}++-- these apply to types+data DataFamily =+    DataAbstract                   -- abstract internal type, has children of representation unknown and irrelevant.+    | DataNone                     -- children don't apply. data constructor for instance+    | DataPrimitive                -- primitive type, children are all numbers.+    | DataEnum {-# UNPACK #-} !Int -- bounded integral type, argument is maximum number+    | DataNormal [Name]            -- child constructors+    | DataAlias !AliasType+    deriving(Eq,Ord,Show)+    {-! derive: Binary !-}++-- | Record describing a data type.+-- * is also a data type containing the type constructors, which are unlifted, yet boxed.++data Constructor = Constructor {+    conName      :: Name,         -- name of constructor+    conType      :: E,            -- type of constructor+    conExpr      :: E,            -- expression which constructs this value+    conOrigSlots :: [Slot],       -- original slots+    conInhabits  :: Name,         -- what constructor it inhabits, similar to conType, but not quite.+    conVirtual   :: Maybe [Name], -- whether this is a virtual constructor that translates into an enum and its siblings+    conChildren  :: DataFamily,+    conCTYPE     :: Maybe ExtType -- external type+    } deriving(Show)+    {-! derive: Binary !-}++data Slot =+    SlotNormal E+    | SlotUnpacked E !Name [E]+    | SlotExistential TVr+    deriving(Eq,Ord,Show)+    {-! derive: Binary !-}++mapESlot f (SlotExistential t) = SlotExistential t { tvrType = f (tvrType t) }+mapESlot f (SlotNormal e) = SlotNormal $ f e+mapESlot f (SlotUnpacked e n es) = SlotUnpacked (f e) n (map f es)++conSlots s = getSlots $ conOrigSlots s++getSlots ss = concatMap f ss where+    f (SlotNormal e) = [e]+    f (SlotUnpacked _ _ es) = es+    f (SlotExistential e) = [tvrType e]++getHsSlots ss = map f ss where+    f (SlotNormal e) = e+    f (SlotUnpacked e _ es) = e+    f (SlotExistential e) = tvrType e++newtype DataTable = DataTable (Map.Map Name Constructor)+    deriving(Monoid)++instance Binary DataTable where+    put (DataTable dt) = putMap dt+    get = fmap DataTable getMap++emptyConstructor = Constructor {+    conName      = error "emptyConstructor.conName",+    conType      = Unknown,+    conOrigSlots = [],+    conExpr      = Unknown,+    conInhabits  = error "emptyConstructor.conInhabits",+    conVirtual   = Nothing,+    conCTYPE     = Nothing,+    conChildren  = DataNone+    }++instance HasSize DataTable where+    size (DataTable d) = Map.size d++{-# NOINLINE getConstructor #-}+getConstructor :: Monad m => Name -> DataTable -> m Constructor+getConstructor n _ | isJust me = return (emptyConstructor {+    conName = n, conType = e,+    conExpr = foldr ELam (foldl eAp (mktBox e) (map EVar tvrs)) tvrs,+    conInhabits = s_Star, conOrigSlots = map SlotNormal sts }) where+        sts = map tvrType ss+        tvrs = [ tvr { tvrIdent = i , tvrType = t } | i <- anonymousIds | t <- sts ]+        (_,ss) = fromPi e+        me@(~(Just e)) = fromConjured modBox n `mplus` fromConjured modAbsurd n+getConstructor n _ | RawType <- nameType n = return $ primitiveConstructor n+getConstructor n _ | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = return $ snd $ tunboxedtuple v+getConstructor n _ | Just v <- fromUnboxedNameTuple n, TypeConstructor <- nameType n = return $ fst $ tunboxedtuple v+getConstructor n (DataTable map) = case Map.lookup n map of+    Just x -> return x+    Nothing -> fail $ "getConstructor: " ++ show (nameType n,n)++-- | return the single constructor of product types+getProduct :: Monad m => DataTable -> E -> m Constructor+getProduct dataTable e | (ELit LitCons { litName = cn }) <-+    followAliases dataTable e, Just c <- getConstructor cn dataTable = f c where+        f c | DataNormal [x] <- conChildren c = getConstructor x dataTable+            | otherwise = fail "Not Product type"+getProduct _ _ = fail "Not Product type"++tunboxedtuple :: Int -> (Constructor,Constructor)+tunboxedtuple n = (typeCons,dataCons) where+    dataCons = emptyConstructor {+        conName      = dc,+        conType      = dtipe,+        conOrigSlots = map (SlotNormal . EVar) typeVars,+        conExpr      = foldr ($) (ELit litCons+                { litName = dc+                , litArgs = map EVar vars+                , litType = ftipe+                }) (map ELam vars),+        conInhabits  = tc+        }+    typeCons = emptyConstructor {+        conName      = tc,+        conType      = foldr EPi eHash (replicate n tvr { tvrType = eStar }),+        conOrigSlots = replicate n (SlotNormal eStar),+        conExpr      = tipe,+        conInhabits  = s_Hash,+        conChildren  = DataNormal [dc]+        }+    dc = unboxedNameTuple DataConstructor n+    tc = unboxedNameTuple TypeConstructor n+    tipe = foldr ELam ftipe typeVars+    typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- anonymousIds ]+    vars =  [ tvr { tvrType = EVar t, tvrIdent = v } | v <- map anonymous [ n + 8, n + 9 ..] | t <- typeVars ]+    ftipe = ELit (litCons { litName = tc, litArgs = map EVar typeVars, litType = eHash })+    dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = emptyId } | v <- vars]) typeVars++-- | conjured data types, these data types are created as needed and can be of any type, their+-- actual type is encoded in their names.+--+-- Absurd - this is a type that it used to default otherwise unconstrained+-- types, it is not special in any particular way but is just an arbitrary type+-- to give to things.+--+-- Box - this type can be used to represent any boxed values. It is considered+-- equivalent to all boxed values so is not a very precise type. It is used in+-- the final stages of compilation before core mangling so that optimizations+-- that were previously blocked by type variables can be carried out.++tAbsurd k = ELit (litCons {+    litName = nameConjured modAbsurd k, litArgs = [], litType = k })+mktBox  k = ELit (litCons {+    litName = nameConjured modBox k, litArgs = [],+    litType = k, litAliasFor = af }) where+        af = case k of+            EPi TVr { tvrType = t1 } t2 -> Just (ELam tvr { tvrType = t1 } (mktBox t2))+            _ -> Nothing++tarrow = emptyConstructor {+            conName = tc_Arrow,+            conType = EPi (tVr emptyId eStar) (EPi (tVr emptyId eStar) eStar),+            conOrigSlots = [SlotNormal eStar,SlotNormal eStar],+            conExpr = ELam (tVr va1 eStar) (ELam (tVr va2 eStar) (EPi (tVr emptyId (EVar $ tVr va1 eStar)) (EVar $ tVr va2 eStar))),+            conInhabits = s_Star,+            conChildren = DataAbstract+        }++primitiveConstructor name = emptyConstructor {+    conName = name,+    conType = eHash,+    conExpr = ELit (litCons { litName = name, litArgs = [], litType = eHash }),+    conInhabits = s_Hash,+    conChildren = DataPrimitive+    }++sortName :: ESort -> Name+sortName s = f s where+    f EStar          = s_Star     -- ^ the sort of boxed lazy types+    f EBang          = s_Bang     -- ^ the sort of boxed strict types+    f EHash          = s_Hash     -- ^ the sort of unboxed types+    f ETuple         = s_Tuple    -- ^ the sort of unboxed tuples+    f EHashHash      = s_HashHash -- ^ the supersort of unboxed types+    f EStarStar      = s_StarStar -- ^ the supersort of boxed types+    f (ESortNamed n) = n          -- ^ user defined sorts++sortConstructor name ss = emptyConstructor {+    conName = name,+    conType = ESort ss,+    conExpr = ESort (ESortNamed name),+    conInhabits = sortName ss+}++typesCompatable :: forall m . Monad m => E -> E -> m ()+typesCompatable a b = f etherealIds a b where+        f :: [Id] -> E -> E -> m ()+        f _ (ESort a) (ESort b) = when (a /= b) $ fail $ "Sorts don't match: " ++ pprint (ESort a,ESort b)+        f _ (EVar a) (EVar b) = when (a /= b) $ fail $ "Vars don't match: " ++ pprint (a,b)+        -- we expand aliases first, because the newtype might have phantom types as arguments+        f c (ELit (LitCons {  litAliasFor = Just af, litArgs = as })) b = do+            f c (foldl eAp af as) b+        f c a (ELit (LitCons {  litAliasFor = Just af, litArgs = as })) = do+            f c a (foldl eAp af as)+        f c (ELit LitCons { litName = n, litArgs = xs, litType = t }) (ELit LitCons { litName = n', litArgs = xs', litType = t' }) | n == n' = do+            f c t t'+            when (not $ sameShape1 xs xs') $ fail "Arg lists don't match"+            zipWithM_ (f c) xs xs'+        f c (EAp a b) (EAp a' b') = do+            f c a a'+            f c b b'+        f c (ELam va ea) (ELam vb eb) = lam va ea vb eb c+        f c (EPi va ea) (EPi vb eb)   = lam va ea vb eb c+        f c (EPi (TVr { tvrIdent = eid, tvrType =  a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) | eid == emptyId, conName tarrow == n, t == eStar = do+            f c a a'+            f c b b'+        f c (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) (EPi (TVr { tvrIdent = eid, tvrType =  a}) b)  | eid == emptyId, conName tarrow == n, t == eStar = do+            f c a a'+            f c b b'+        f _ a b | boxCompat a b || boxCompat b a = return ()+        f _ a b = fail $ "Types don't match:" ++ pprint (a,b)++        lam :: TVr -> E -> TVr -> E -> [Id] -> m ()+        lam va ea vb eb ~(c:cs) = do+            f (c:cs) (tvrType va) (tvrType vb)+            f cs (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb)+        boxCompat (ELit (LitCons { litName = n }))  t | Just e <- fromConjured modBox n =  e == getType t+        boxCompat _ _ = False++extractPrimitive :: Monad m => DataTable -> E -> m (E,(ExtType,E))+extractPrimitive dataTable e = case followAliases dataTable (getType e) of+    st@(ELit LitCons { litName = c, litArgs = [], litType = t })+        | t == eHash -> return (e,(ExtType (packString $show c),st))+        | otherwise -> do+            Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable+            Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable+            (ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st+            let tvra = tVr vn st+                (vn:_) = newIds (freeIds e)+            return (eCase e  [Alt (litCons { litName = cn, litArgs = [tvra],+                litType = (getType e) }) (EVar tvra)] Unknown,(ExtType (packString $ show n),st))+    e' -> fail $ "extractPrimitive: " ++ show (e,e')++boxPrimitive ::+    Monad m+    => DataTable+    -> E         -- primitive to box+    -> E         -- what type we want it to have+    -> m (E,(ExtType,E))+boxPrimitive dataTable e et = case followAliases dataTable et of+    st@(ELit LitCons { litName = c, litArgs = [], litType = t })+        | t == eHash -> return (e,(ExtType . packString $ show c,st))+        | otherwise -> do+            Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable+            Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable+            (ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st+            let tvra = tVr vn st+                (vn:_) = newIds (freeVars (e,et))+            if isManifestAtomic e then+                return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(ExtType . packString $ show n,st))+             else+                return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(ExtType . packString $ show n,st))+    e' -> fail $ "boxPrimitive: " ++ show (e,e')++extractIO :: Monad m => E -> m E+extractIO e = f e where+    f (ELit LitCons { litName = c, litArgs = [x] }) | c == tc_IO  = return x+    f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as)+    f _ = fail "extractIO: not an IO type"++-- extract IO or an unboxed version of it, (ST, World -> (# Wold, a #))+extractIO' :: E -> ([E],Bool,E)+extractIO' e = f e [] where+    f (ELit LitCons { litName = c, litArgs = [x] }) rs | c == tc_IO  = (reverse rs, True,x)+    f (ELit LitCons { litName = c, litArgs = [_,x] }) rs | c == tc_ST  = (reverse rs, True,x)+    f (expandAlias -> Just t) rs = f t rs+    f (fromPi -> (fromUnboxedTuple -> Just [s',x],[getType -> s''])) rs+        | isState_ s' && isState_ s'' = (reverse rs, True,x)+    f (EPi v e) rs = f e (getType v:rs)+    f e rs = (reverse rs, False,e)+--    f (fromPi -> (getType -> s',[getType -> s''])) | isState_ s' && isState_ s'' = (True,tUnit)++data ExtTypeInfo+    = ExtTypeVoid                  -- maps to 'void'+    | ExtTypeRaw ExtType           -- value is an unboxed type suitable for passing with the argument calling convention+    | ExtTypeBoxed Name E ExtType  -- boxed type, name is constructor of box, E is type of the slice, and ExtType is the calling convention to use++extTypeInfoExtType (ExtTypeRaw et) = et+extTypeInfoExtType (ExtTypeBoxed _ _ et) = et+extTypeInfoExtType ExtTypeVoid = "void"++lookupExtTypeInfo :: Monad m => DataTable -> E -> m ExtTypeInfo+lookupExtTypeInfo dataTable oe = f Set.empty oe where+    f :: Monad m => Set.Set Name -> E -> m ExtTypeInfo+    -- handle the void context ones first+    f _ e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_State_ = return ExtTypeVoid+    -- if the constructor is in the external type map, replace its external+    -- type with the one in the map+    f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Ptr = do+        ExtTypeBoxed b t _ <- g seen e  -- we know a pointer is a boxed BitsPtr+        case f seen ta of+            Just (ExtTypeBoxed _ _ (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*")+            Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*")+            _ -> return $ ExtTypeBoxed b t "HsPtr"+    f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Complex = do+        case f seen ta of+            Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeRaw (ExtType $ "_Complex " `mappend` et)+            _ -> fail "invalid _Complex type"+    f seen e@(ELit LitCons { litName = c }) | Just (conCTYPE -> Just et) <- getConstructor c dataTable = do+        return $ case g seen e of+            Just (ExtTypeBoxed b t _) -> ExtTypeBoxed b t et+            Just ExtTypeVoid -> ExtTypeVoid+            _ -> ExtTypeRaw et+    f seen e = g seen e+    -- if we are a raw type, we can be foreigned+    g _ (ELit LitCons { litName = c })+        | Just et <- Map.lookup c rawExtTypeMap = return (ExtTypeRaw et)+    -- if we are a single constructor data type with a single foreignable unboxed+    -- slot, we are foreiginable+    g _ (ELit LitCons { litName = c, litAliasFor = Nothing })+        | Just Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable,+          Just Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable,+          Just (ExtTypeRaw et) <- lookupExtTypeInfo dataTable st = return $ ExtTypeBoxed cn st et+    g seen e@(ELit LitCons { litName = n }) | Just e' <- followAlias dataTable e,+        n `Set.notMember` seen = f (Set.insert n seen) e'+    g _ e = fail $ "lookupExtTypeInfo: " ++ show (oe,e)++expandAlias :: Monad m => E -> m E+expandAlias (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as)+expandAlias  _ = fail "expandAlias: not alias"++followAlias :: Monad m => DataTable -> E -> m E+followAlias _ (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as)+followAlias _  _ = fail "followAlias: not alias"++followAliases :: DataTable -> E -> E+followAliases _dataTable e = f e where+    f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as)+    f e = e++dataTablePrims = DataTable $ Map.fromList ([ (conName x,x) | x <- [tarrow] ])++deriveClasses :: IdMap Comb -> DataTable -> [(SrcLoc,Name,Name)] -> [(TVr,E)]+deriveClasses cmap dt@(DataTable mp) ctd = concatMap f ctd where+    f (_,cd,t) | Just c <- getConstructor t dt, TypeConstructor == nameType (conName c), Just is <- conVirtual c = g is c cd+    f _ = []+    g is c cl = h cl where+        lupvar v = EVar (combHead comb) where+            Just comb = mlookup (toId v) cmap+        typ = conExpr c+        DataNormal [con] = conChildren c+        Just conr = getConstructor con (DataTable mp)+        [it@(ELit LitCons { litName = it_name })] = conSlots conr+        Just itr = getConstructor it_name (DataTable mp)+        DataEnum mv = conChildren itr+        v1 = tvr { tvrIdent = anonymous 1,  tvrType = typ }+        v2 = tvr { tvrIdent = anonymous 2,  tvrType = typ }+        i1 = tvr { tvrIdent = anonymous 3,  tvrType = it }+        i2 = tvr { tvrIdent = anonymous 4,  tvrType = it }+        b3 = tvr { tvrIdent = anonymous 5,  tvrType = tBoolzh }+        val1 = tvr { tvrIdent = anonymous 7, tvrType = typ }+        unbox e = ELam v1 (ELam v2 (ec (EVar v1) i1 (ec (EVar v2) i2 e)))  where+            ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown+        h cl | cl == class_Eq = [mkCmpFunc v_equals Op.Eq]+        h cl | cl == class_Ord = [+                mkCmpFunc v_geq Op.UGte,+                mkCmpFunc v_leq Op.ULte,+                mkCmpFunc v_lt  Op.ULt,+                mkCmpFunc v_gt  Op.UGt]+        h cl | Just ans <- lookup cl mthds = ans where+            mthds = [(class_Enum,[+                    (iv_te,ib_te),+                    (iv_fe,ib_fe),+                    iv v_succ succ_body,+                    iv v_pred pred_body,+                    iv v_enumFrom from_body,+                    iv v_enumFromTo fromTo_body,+                    iv v_enumFromThen fromThen_body,+                    iv v_enumFromThenTo fromThenTo_body+                ]),+                (class_Ix,[+                    iv v_range range_body,+--                    iv v_inRange inRange_body,+                    iv v_index index_body+                ])]+            iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_toEnum (nameName $ conName c), tvrType = getType ib_te }+            iv_fe = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_fromEnum (nameName $ conName c), tvrType = getType ib_fe }+            iv fname body = (setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType body },body)+            succ_body = foldl EAp (lupvar v_enum_succ) [typ, box, debox, max]+            pred_body = foldl EAp (lupvar v_enum_pred) [typ, box, debox]+            from_body = foldl EAp (lupvar v_enum_from) [typ, box, debox, max]+            fromTo_body = foldl EAp (lupvar v_enum_fromTo) [typ, box, debox]+            fromThen_body = foldl EAp (lupvar v_enum_fromThen) [typ, box, debox, max]+            fromThenTo_body = foldl EAp (lupvar v_enum_fromThenTo) [typ, box, debox]+            range_body = foldl EAp (lupvar v_ix_range) [typ, box, debox]+            --inRange_body = foldl EAp (lupvar v_ix_inRange) [typ, box, debox]+            index_body = foldl EAp (lupvar v_ix_index) [typ, box, debox]++            ib_te = foldl EAp (lupvar v_enum_toEnum) [typ, box, toEzh (mv - 1)]+            ib_fe = ELam val1 (create_uintegralCast_toInt con tEnumzh (EVar val1))++            max = ELit (LitInt (fromIntegral $ mv - 1) tEnumzh)++            box = ELam i1 (ELit (litCons { litName = con, litArgs = [EVar i1], litType = typ }))+            debox = ELam v1 (ec (EVar v1) i1 (EVar i1))  where+                ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown++        h _ = []+        mkCmpFunc fname op = (iv_eq,ib_eq) where+            ib_eq = unbox (eStrictLet b3 (oper_IIB op (EVar i1) (EVar i2)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar b3], litType = tBool })))+            iv_eq = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType ib_eq }+    oper_IIB op a b = EPrim (Op (Op.BinOp op Op.bits16 Op.bits16) Op.bits16) [a,b] tBoolzh++create_integralCast conv c1 t1 c2 t2 e t = eCase e [Alt (litCons { litName = c1, litArgs = [tvra], litType = te }) cc] Unknown  where+    te = getType e+    ELit LitCons { litName = n1, litArgs = [] } = t1+    ELit LitCons { litName = n2, litArgs = [] } = t2+    Just n1' = nameToOpTy n1+    Just n2' = nameToOpTy n2+    tvra =  tVr va2 t1+    tvrb =  tVr va3 t2+    cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else+        eStrictLet  tvrb (EPrim (Op (Op.ConvOp conv n1') n2') [EVar tvra] t2)  (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t }))++nameToOpTy n = do RawType <- return $ nameType n; Op.readTy (show n)++create_uintegralCast_toInt c1 t1 e = create_integralCast Op.U2U c1 t1 dc_Int tIntzh e tInt++updateLit :: DataTable -> Lit e t -> Lit e t+updateLit _ l@LitInt {} = l+updateLit dataTable lc@LitCons { litAliasFor = Just {} } = lc+updateLit dataTable lc@LitCons { litName = n } =  lc { litAliasFor = af } where+    af = do+        Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable+        Constructor { conChildren = DataAlias ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable+        return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- anonymousIds])++removeNewtypes :: DataTable -> E -> E+removeNewtypes dataTable e = runIdentity (f e) where+    f ec@ECase {} = emapEGH f f return ec { eCaseAlts = map g (eCaseAlts ec) } where+        g (Alt l e) = Alt (gl $ updateLit dataTable l) e+    f (ELit l) = emapEGH f f return (ELit (gl $ updateLit dataTable l))+    f e = emapEGH f f return e+    gl lc@LitCons { litAliasFor = Just e }  = lc { litAliasFor = Just $ removeNewtypes dataTable e }+    gl l = l++collectDeriving :: [HsDecl] -> [(SrcLoc,Name,Name)]+collectDeriving ds = concatMap f ds where+    f decl@HsDataDecl {} = g decl+    f decl@HsDeclDeriving {} = h decl+    f _ = []+    g decl = [(hsDeclSrcLoc decl, toName ClassName c,+        toName TypeConstructor (hsDeclName decl)) | c <- hsDeclDerives decl ]+    h decl@(hsDeclClassHead -> ch) | [(ltc -> Just t)] <- hsClassHeadArgs ch = [(hsDeclSrcLoc decl,toName ClassName (hsClassHead ch), t)] where+            ltc (HsTyApp t1 _) = ltc t1+            ltc (HsTyCon n) = Just (toName TypeConstructor n)+            ltc x = Nothing+    h _ = []++{-# NOINLINE toDataTable #-}+toDataTable :: (Map.Map Name Kind) -> (Map.Map Name Type) -> [HsDecl] -> DataTable -> DataTable+toDataTable km cm ds currentDataTable = newDataTable  where+    newDataTable = DataTable (Map.mapWithKey fixupMap $+        Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` keys primitiveAliases ])+    fullDataTable = (newDataTable `mappend` currentDataTable)+    procNewTypes c = c { conExpr = f (conExpr c), conType = f (conType c), conOrigSlots = map (mapESlot f) (conOrigSlots c) } where+        f = removeNewtypes fullDataTable+    fixupMap k _ | Just n <- getConstructor k dataTablePrims = n+    fixupMap _ n = n+    ds' = Seq.toList $ execWriter (mapM_ f ds)+    newtypeLoopBreakers = map fst $ fst $  G.findLoopBreakers (const 0) (const True) (G.newGraph newtypeDeps fst snd) where+        newtypeDeps = [ (n,concatMap (fm . hsBangType) $ hsConDeclArgs c) |+            HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = n, hsDeclCons = (head -> c) } <- ds ]+        fm t = execWriter $ f t+        f HsTyCon { hsTypeName = n } = tell [n]+        f t = traverseHsType_ f t+    f decl@HsDataDecl { hsDeclDeclType = DeclTypeNewtype,  hsDeclName = nn, hsDeclCons = cs } =+        dt decl (if nn `elem` newtypeLoopBreakers then DataAlias RecursiveAlias else DataAlias ErasedAlias) cs+    f decl@HsDataDecl { hsDeclDeclType = DeclTypeKind } = dkind decl+    f decl@HsDataDecl { hsDeclCons = cs } = dt decl DataNone cs+    f _ = return ()+    dt decl DataNone cs@(_:_:_) | all null (map hsConDeclArgs cs) = do+        let virtualCons'@(fc:_) = map (makeData DataNone typeInfo) cs+            typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl)+            virt = Just (map conName virtualCons')+            f (n,vc) = vc { conExpr = ELit (litCons { litName = consName, litArgs = [ELit (LitInt (fromIntegral n) rtype)], litType = conType vc }), conVirtual = virt }+            virtualCons = map f (zip [(0 :: Int) ..] virtualCons')+            consName =  mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType))+            rtypeName =  mapName (id,(++ "#")) $ toName TypeConstructor (nameName (conName theType))+            rtype = ELit litCons { litName = rtypeName, litType = eHash, litAliasFor = Just tEnumzh }+            dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr (anonymous 3) rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr (anonymous 6) rtype)], litType =  conExpr theType })) }+            rtypeCons = emptyConstructor {+                conName = rtypeName,+                conType = eHash,+                conExpr = rtype,+                conInhabits = s_Hash,+                conChildren = DataEnum (length virtualCons)+                }+        tell (Seq.fromList virtualCons)+        tell (Seq.singleton dataCons)+        tell (Seq.singleton rtypeCons)+        tell $ Seq.singleton theType { conChildren = DataNormal [consName], conVirtual = virt }+        return ()++    dt decl alias cs = do+        let dataCons = map (makeData alias typeInfo) cs+            typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl)+        tell (Seq.fromList dataCons)+        tell $ Seq.singleton theType { conChildren = DataNormal (map conName dataCons) }++    dkind HsDataDecl { .. } = do+        tell $ Seq.singleton $ (sortConstructor hsDeclName EHashHash) {+            conChildren = DataNormal (map hsConDeclName hsDeclCons) }+        flip mapM_  hsDeclCons $ \ HsConDecl { .. } -> do+            let Just theKind = kind `fmap` (Map.lookup hsConDeclName km)+                (theTypeFKind,theTypeKArgs') = fromPi theKind+                theTypeArgs = [ tvr { tvrIdent = x } | tvr  <- theTypeKArgs' | x <- anonymousIds ]+                theTypeExpr = ELit litCons {+                    litName = hsConDeclName,+                    litArgs = map EVar theTypeArgs,+                    litType = theTypeFKind }+            tell $ Seq.singleton emptyConstructor {+                conName      = hsConDeclName,+                conType      = theKind,+                conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,+                conExpr      = foldr ($) theTypeExpr (map ELam theTypeArgs),+                conInhabits  = hsDeclName+            }+    dkind _ = error "dkind passed bad decl"++    makeData alias (theType,theTypeArgs,theTypeExpr) x = theData where+        theData = emptyConstructor {+            conName = dataConsName,+            conType =foldr ($) (getType theExpr) (map EPi theTypeArgs),+            conOrigSlots = origSlots,+            conExpr = theExpr,+            conInhabits = conName theType,+            conChildren = alias+            }+        dataConsName =  toName Name.DataConstructor (hsConDeclName x)++        theExpr =  foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars++        strictize tslots con = E.Subst.subst tvr { tvrIdent = sillyId } Unknown $ f tslots con where+            f (Left (v,False):rs) con = f rs con+            f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con)+            f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where+                pat = litCons { litName = dc, litArgs = rcs, litType = (getType v) }+            f [] con = con++        -- substitution is only about substituting type variables+        (ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do+            let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); ~(Just ty) -> ([],ty)+            mapM_ (newName anonymousIds ()) vs+            tipe' ty+        subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- anonymousIds ]++        origSlots = map SlotExistential existentials ++ map f tslots where+            f (Left (e,_)) = SlotNormal (getType e)+            f (Right (e,n,es)) = SlotUnpacked (getType e) n (map getType es)+        hsvars = existentials ++ map f tslots where+            f (Left (e,_)) = e+            f (Right (e,_,_)) = e+        dvars = existentials ++ concatMap f tslots where+            f (Left (e,_)) = [e]+            f (Right (_,_,es)) = es+        tslots = f (newIds fvset) (map isHsBangedTy (hsConDeclArgs x)) origArgs where+            f (i:is) (False:bs) (e:es) = Left (e { tvrIdent = i, tvrType = subst (tvrType e) },False):f is bs es+            f (i:j:is) (True:bs) (e:es) = maybe  (Left (e { tvrIdent = i, tvrType = subst (tvrType e) },True):f is bs es) id $ g e (tvrType e) where+                g e te = do+                    ELit LitCons { litName = n } <- return $ followAliases fullDataTable te+                    Constructor { conChildren = DataNormal [dc] } <- getConstructor n fullDataTable+                    con <- getConstructor dc fullDataTable+                    case (conChildren con,slotTypes fullDataTable dc te) of+                        (DataAlias ErasedAlias,[nt]) -> g e nt+                        (_,[st]) -> do+                            let nv = tvr { tvrIdent = j, tvrType = st }+                            return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es+                        _ -> fail "not unboxable"+            f _ [] [] = []+            f _ _ _ = error "DataConstructors.tslots"+            fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (take (length theTypeArgs + 2) anonymousIds)++        -- existentials are free variables in the arguments, that arn't bound in the type+        existentials = values $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr)++        -- arguments that the front end passes or pulls out of this constructor+        --hsArgs = existentials ++ [ tvr {tvrIdent = x} | tvr <- origArgs | x <- drop (5 + length theTypeArgs) [2,4..] ]++    makeType decl ct = (theType,theTypeArgs,theTypeExpr) where+        theTypeName = toName Name.TypeConstructor (hsDeclName decl)+        Just theKind = kind `fmap` (Map.lookup theTypeName km)+        (theTypeFKind,theTypeKArgs') = fromPi theKind+        theTypeArgs = [ tvr { tvrIdent = x } | tvr  <- theTypeKArgs' | x <- anonymousIds ]+        theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind }+        theType = emptyConstructor {+            conCTYPE     = fmap (ExtType . packString) ct,+            conExpr      = foldr ($) theTypeExpr (map ELam theTypeArgs),+            conInhabits  = if theTypeFKind == eStar then s_Star else s_Hash,+            conName      = theTypeName,+            conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,+            conType      = theKind,+            conVirtual   = Nothing+            }++isHsBangedTy HsBangedTy {} = True+isHsBangedTy _ = False++getConstructorArities  :: DataTable -> [(Name,Int)]+getConstructorArities (DataTable dt) = [ (n,length $ conSlots c) | (n,c) <- Map.toList dt]++constructionExpression ::+    DataTable -- ^ table of data constructors+    -> Name   -- ^ name of said constructor+    -> E      -- ^ type of eventual constructor+    -> E      -- ^ saturated lambda calculus term+constructionExpression dataTable n typ@(ELit LitCons { litName = pn, litArgs = xs })+    | DataAlias ErasedAlias <- conChildren mc = ELam var (EVar var)+    | DataAlias RecursiveAlias <- conChildren mc = let var' = var { tvrType = st } in ELam var' (prim_unsafeCoerce (EVar var') typ)+    | pn == conName pc = sub (conExpr mc) where+    ~[st] = slotTypes dataTable n typ+    var = tvr { tvrIdent = vid, tvrType = typ }+    (vid:_) = newIds (freeVars typ)+    Just mc = getConstructor n dataTable+    Just pc = getConstructor (conInhabits mc) dataTable+    sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]+constructionExpression wdt n e | Just fa <- followAlias wdt e  = constructionExpression wdt n fa+constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e++deconstructionExpression ::+    UniqueProducer m+    => DataTable  -- ^ table of data constructors+    -> Name       -- ^ name of said constructor+    -> E          -- ^ type of pattern+    -> [TVr]      -- ^ variables to be bound+    -> E          -- ^ body of alt+    -> m (Alt E)  -- ^ resulting alternative+deconstructionExpression dataTable name typ@(ELit LitCons { litName = pn, litArgs = xs }) vs  e | pn == conName pc = ans where+    Just mc = getConstructor name dataTable+    Just pc = getConstructor (conInhabits mc) dataTable+    sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]+    ans = case conVirtual mc of+        Just _ -> return $ let ELit LitCons {  litArgs = [ELit (LitInt n t)] } = conExpr mc in Alt (LitInt n t) e+        Nothing -> do+            let f vs (SlotExistential t:ss) rs ls = f vs ss (t:rs) ls+                f (v:vs) (SlotNormal _:ss) rs ls = f vs ss (v:rs) ls+                f (v:vs) (SlotUnpacked e n es:ss) rs ls = do+                    let g t = do+                            s <- newUniq+                            return $ tVr (anonymous s) t+                    as <- mapM g (map sub es)+                    f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = sub e }):ls)+                f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e)+                f _ _ _ _ = error "DataConstructors.deconstructuonExpression.f"+            f vs (conOrigSlots mc) [] []+deconstructionExpression wdt n ty vs e | Just fa <- followAlias wdt ty  = deconstructionExpression wdt n fa vs e+deconstructionExpression _ n e _ _ = error $ "deconstructionExpression: error in " ++ show n ++ ": " ++ show e++slotTypes ::+    DataTable -- ^ table of data constructors+    -> Name   -- ^ name of constructor+    -> E      -- ^ type of value+    -> [E]    -- ^ type of each slot+slotTypes wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ })+    | pn == conName pc = [sub x | x <- conSlots mc ]+    where+    Identity mc = getConstructor n wdt+    Identity pc = getConstructor (conInhabits mc) wdt+    sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]+slotTypes wdt n kind+    | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc)+    -- | sortKindLike kind, (e,ts) <- fromPi kind = (conSlots mc)+    where Identity mc = getConstructor n wdt+slotTypes wdt n e | Just fa <- followAlias wdt e  = slotTypes wdt n fa+slotTypes _ n e = error $ "slotTypes: error in " ++ show n ++ ": " ++ show e++slotTypesHs ::+    DataTable -- ^ table of data constructors+    -> Name   -- ^ name of constructor+    -> E      -- ^ type of value+    -> [E]    -- ^ type of each slot+slotTypesHs wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ })+    | pn == conName pc = [sub x | x <- getHsSlots $ conOrigSlots mc ]+    where+    Identity mc = getConstructor n wdt+    Identity pc = getConstructor (conInhabits mc) wdt+    sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]+slotTypesHs wdt n kind+    | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc)+    where Identity mc = getConstructor n wdt+slotTypesHs wdt n e | Just fa <- followAlias wdt e  = slotTypes wdt n fa+slotTypesHs _ n e = error $ "slotTypesHs: error in " ++ show n ++ ": " ++ show e++{-# NOINLINE showDataTable #-}+showDataTable (DataTable mp) = vcat xs where+    c con = vcat [t,e,cs,vt,ih,ch,mc] where+        t  = text "::"        <+> ePretty conType+        e  = text "="         <+> ePretty conExpr+        cs = text "slots:"    <+> tupled (map ePretty (conSlots con))+        vt = text "virtual:"  <+> tshow conVirtual+        ih = text "inhabits:" <+> tshow conInhabits+        ch = text "children:" <+> tshow conChildren+        mc = text "CTYPE:"    <+> tshow conCTYPE+        Constructor { .. } = con+    xs = [text x <+> hang 0 (c y) | (x,y) <- ds ]+    ds = sortBy (\(x,_) (y,_) -> compare x y) [(show x,y)  | (x,y) <-  Map.toList mp]++{-# NOINLINE samplePrimitiveDataTable #-}+samplePrimitiveDataTable :: DataTable+samplePrimitiveDataTable = DataTable $ Map.fromList [ (x,c) | x <- xs, c <- getConstructor x mempty] where+    nt v = map (flip unboxedNameTuple (v::Int)) [DataConstructor, TypeConstructor]+    xs = nt 0 ++ nt 3 ++ [nameConjured modAbsurd eStar,nameConjured modBox hs, nameConjured modAbsurd hs', nameConjured modBox hs',rt_bits16,rt_bits_ptr_]+    hs = EPi (tVr emptyId eHash) eStar+    hs' = tFunc eStar (tFunc (tFunc eStar eHash) eStar)++getSiblings :: DataTable -> Name -> Maybe [Name]+getSiblings dt n+    | Just c <- getConstructor n dt, Just Constructor { conChildren = DataNormal cs } <- getConstructor (conInhabits c) dt = Just cs+    | otherwise =  Nothing++numberSiblings :: DataTable -> Name -> Maybe Int+numberSiblings dt n+    | Just c <- getConstructor n dt, Just Constructor { conChildren = cc } <- getConstructor (conInhabits c) dt = case cc of+        DataNormal ds -> Just $ length ds+        DataEnum n -> Just n+        _ -> Nothing+    | otherwise =  Nothing++-- whether the type has a single slot+onlyChild :: DataTable -> Name -> Bool+onlyChild dt n = isJust ans where+    ans = do+        c <- getConstructor n dt+        case conChildren c of+            DataNormal [_] -> return ()+            _ -> do+                c <- getConstructor (conInhabits c) dt+                case conChildren c of+                    DataNormal [_] -> return ()+                    _ -> fail "not cpr"++pprintTypeOfCons :: (Monad m,DocLike a) => DataTable -> Name -> m a+pprintTypeOfCons dataTable name = do+    c <- getConstructor name dataTable+    return $ pprintTypeAsHs (conType c)++pprintTypeAsHs :: DocLike a => E -> a+pprintTypeAsHs e = unparse $ runVarName (f e) where+    f e | e == eStar = return $ atom $ text "*"+        | e == eHash = return $ atom $ text "#"+    f (EPi (TVr { tvrIdent = eid, tvrType = t1 }) t2) | eid == emptyId = do+        t1 <- f t1+        t2 <- f t2+        return $ t1 `arr` t2+    f (ELit LitCons { litName = n, litArgs = as }) | (a:as') <- reverse as = f $ EAp (ELit litCons { litName = n, litArgs = reverse as' }) a+    f (ELit LitCons { litName = n, litArgs = [] }) = return $ atom $ text $ show n+    f (EAp a b) = do+        a <- f a+        b <- f b+        return $ a `app` b+    f (EVar v) = do+        vo <- newLookupName ['a' .. ] () (tvrIdent v)+        return $ atom $ char vo+    f v | (e,ts@(_:_)) <- fromPi v = do+        ts' <- mapM (newLookupName ['a'..] () . tvrIdent) ts+        r <- f e+        return $ fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ")  (atomize r)+    f e = error $ "printTypeAsHs: " ++ show e+    arr = bop (R,0) (space D.<> text "->" D.<> space)+    app = bop (L,100) (text " ")++class Monad m => DataTableMonad m where+    getDataTable :: m DataTable+    getDataTable = return mempty++instance DataTableMonad Identity++-- | list of declared data types that map+-- directly to primitive real types++primitiveAliases :: Map.Map Name Name+primitiveAliases = Map.fromList [+    (tc_Bits1,    rt_bool),+    (tc_Bits8,    rt_bits8),+    (tc_Bits16,   rt_bits16),+    (tc_Bits32,   rt_bits32),+    (tc_Bits64,   rt_bits64),+    (tc_Bits128,  rt_bits128),+    (tc_BitsPtr,  rt_bits_ptr_),+    (tc_BitsMax,  rt_bits_max_),+    (tc_Float32,  rt_float32),+    (tc_Float64,  rt_float64),+    (tc_Float80,  rt_float80),+    (tc_Float128, rt_float128)+    ]++-- mapping of primitive types to the C calling convention used+-- when passing to/from foreign functions++rawExtTypeMap :: Map.Map Name ExtType+rawExtTypeMap = Map.fromList [+    (rt_bool,      "bool"),+    (rt_bits8,     "uint8_t"),+    (rt_bits16,    "uint16_t"),+    (rt_bits32,    "uint32_t"),+    (rt_bits64,    "uint64_t"),+    (rt_bits128,   "uint128_t"),+    (rt_bits_ptr_, "uintptr_t" ),+    (rt_bits_max_, "uintmax_t"),+    (rt_float32,   "float"),+    (rt_float64,   "double"),+    (rt_float80,   "long double"),+    (rt_float128,  "__float128")+    ]+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary AliasType where+    put ErasedAlias = do+	    Data.Binary.putWord8 0+    put RecursiveAlias = do+	    Data.Binary.putWord8 1+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return ErasedAlias+	      1 -> do+		    return RecursiveAlias+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary DataFamily where+    put DataAbstract = do+	    Data.Binary.putWord8 0+    put DataNone = do+	    Data.Binary.putWord8 1+    put DataPrimitive = do+	    Data.Binary.putWord8 2+    put (DataEnum aa) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put aa+    put (DataNormal ab) = do+	    Data.Binary.putWord8 4+	    Data.Binary.put ab+    put (DataAlias ac) = do+	    Data.Binary.putWord8 5+	    Data.Binary.put ac+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return DataAbstract+	      1 -> do+		    return DataNone+	      2 -> do+		    return DataPrimitive+	      3 -> do+		    aa <- Data.Binary.get+		    return (DataEnum aa)+	      4 -> do+		    ab <- Data.Binary.get+		    return (DataNormal ab)+	      5 -> do+		    ac <- Data.Binary.get+		    return (DataAlias ac)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Constructor where+    put (Constructor aa ab ac ad ae af ag ah) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+	    Data.Binary.put ae+	    Data.Binary.put af+	    Data.Binary.put ag+	    Data.Binary.put ah+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    ae <- get+    af <- get+    ag <- get+    ah <- get+    return (Constructor aa ab ac ad ae af ag ah)++instance Data.Binary.Binary Slot where+    put (SlotNormal aa) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+    put (SlotUnpacked ab ac ad) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+    put (SlotExistential ae) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ae+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    return (SlotNormal aa)+	      1 -> do+		    ab <- Data.Binary.get+		    ac <- Data.Binary.get+		    ad <- Data.Binary.get+		    return (SlotUnpacked ab ac ad)+	      2 -> do+		    ae <- Data.Binary.get+		    return (SlotExistential ae)+	      _ -> fail "invalid binary data found"++--  Imported from other files :-
+ drift_processed/DataConstructors.hs-boot view
@@ -0,0 +1,17 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/DataConstructors.hs-boot" #-}+module DataConstructors where+++import E.E+import Name.Name++data DataTable+followAliases :: DataTable -> E -> E+followAlias :: Monad m => DataTable -> E -> m E+typesCompatable :: Monad m => E -> E -> m ()+updateLit :: DataTable -> Lit e t -> Lit e t+slotTypes :: DataTable -> Name -> E -> [E]+mktBox :: E -> E+{-* Generated by DrIFT : Look, but Don't Touch. *-}+--  Imported from other files :-
+ drift_processed/E/CPR.hs view
@@ -0,0 +1,182 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/CPR.hs" #-}+module E.CPR(Val(..), cprAnalyzeDs, cprAnalyzeProgram) where++import Control.Monad.Writer(runWriter,tell,Monoid(..))+import Data.Binary+import Data.Monoid()+import Data.Typeable+import qualified Data.Map as Map++import Cmm.Number+import DataConstructors+import Doc.DocLike+import E.E+import E.Program+import GenUtil+import Name.Name+import Name.Names+import Name.VConsts+import Util.SameShape+import qualified Doc.Chars as C+import qualified E.Demand as Demand+import qualified Info.Info as Info++newtype Env = Env (Map.Map TVr Val)+    deriving(Monoid)++data Val =+    Top               -- the top.+    | Fun Val         -- function taking an arg+    | Tup Name [Val]  -- A constructed product+    | VInt Number     -- A number+    | Tag [Name]      -- A nullary constructor, like True, False+    | Bot             -- the bottom+    deriving(Eq,Ord,Typeable)+    {-! derive: Binary !-}++trimVal v = f (0::Int) v where+    f !n Tup {} | n > 5 = Top+    f n (Tup x vs) = Tup x (map (f (n + 1)) vs)+    f n (Fun v) = Fun (f n v)+    f _ x = x++toVal c = case conSlots c of+    [] -> Tag [conName c]+    ss -> Tup (conName c) [ Top | _ <- ss]++instance Show Val where+    showsPrec _ Top = C.top+    showsPrec _ Bot = C.bot+    showsPrec n (Fun v) = C.lambda <> showsPrec n v+    showsPrec _ (Tup n [x,xs]) | n == dc_Cons = shows x <> showChar ':' <> shows xs+    showsPrec _ (Tup n xs) | Just _ <- fromTupname n  = tupled (map shows xs)+    showsPrec _ (Tup n xs) = shows n <> tupled (map shows xs)+    showsPrec _ (VInt n) = shows n+    showsPrec _ (Tag [n]) | n == dc_EmptyList = showString "[]"+    showsPrec _ (Tag [n]) = shows n+    showsPrec _ (Tag ns) = shows ns++lub :: Val -> Val -> Val+lub Bot a = a+lub a Bot = a+lub Top a = Top+lub a Top = Top+lub (Tup a xs) (Tup b ys)+    | a == b, sameShape1 xs ys = Tup a (zipWith lub xs ys)+    | a == b = error "CPR.lub this shouldn't happen"+    | otherwise = Top+lub (Fun l) (Fun r) = Fun (lub l r)+lub (VInt n) (VInt n') | n == n' = VInt n+lub (Tag xs) (Tag ys) = Tag (smerge xs ys)+lub (Tag _) (Tup _ _) = Top+lub (Tup _ _) (Tag _) = Top+lub _ _ = Top+--lub a b = error $ "CPR.lub: " ++ show (a,b)++instance Monoid Val where+    mempty = Bot+    mappend = lub++{-# NOINLINE cprAnalyzeProgram #-}+cprAnalyzeProgram :: Program -> Program+cprAnalyzeProgram prog = ans where+    nds = cprAnalyzeDs (progDataTable prog) (programDs prog)+    ans = programSetDs' nds prog -- { progStats = progStats prog `mappend` stats }++cprAnalyzeDs :: DataTable -> [(TVr,E)] -> [(TVr,E)]+cprAnalyzeDs dataTable ds = fst $ cprAnalyzeBinds dataTable mempty ds++cprAnalyzeBinds :: DataTable -> Env -> [(TVr,E)] -> ([(TVr,E)],Env)+cprAnalyzeBinds dataTable env bs = f env  (decomposeDs bs) [] where+    f env (Left (t,e):rs) zs = case cprAnalyze dataTable env e of+        (e',v) -> f (envInsert t v env) rs ((tvrInfo_u (Info.insert $ trimVal v) t,e'):zs)+    f env (Right xs:rs) zs = g (length xs + 2) ([ (t,(e,Bot)) | (t,e) <- xs]) where+        g 0 mp =  f nenv rs ([ (tvrInfo_u (Info.insert $ trimVal b) t,e)   | (t,(e,b)) <- mp] ++ zs)  where+            nenv = Env (Map.fromList [ (t,b) | (t,(e,b)) <- mp]) `mappend` env+        g n mp = g (n - 1) [ (t,cprAnalyze dataTable nenv e)  | (t,e) <- xs] where+            nenv = Env (Map.fromList [ (t,b) | (t,(e,b)) <- mp]) `mappend` env+    f env [] zs = (reverse zs,env)++envInsert :: TVr -> Val -> Env -> Env+envInsert tvr val (Env mp) = Env $ Map.insert tvr val mp++cprAnalyze :: DataTable -> Env -> E -> (E,Val)+cprAnalyze dataTable env e = cprAnalyze' env e where+    cprAnalyze' (Env mp) (EVar v)+        | Just t <- Map.lookup v mp = (EVar v,t)+        | Just t <- Info.lookup (tvrInfo v)  = (EVar v,t)+        | otherwise = (EVar v,Top)+    cprAnalyze' env ELetRec { eDefs = ds, eBody = e } = (ELetRec ds' e',val) where+        (ds',env') = cprAnalyzeBinds dataTable env ds+        (e',val) = cprAnalyze' (env' `mappend` env) e++    cprAnalyze' env (ELam t e)+        | Just (Demand.S _) <- Info.lookup (tvrInfo t), Just c <- getProduct dataTable (tvrType t) = let+            (e',val) = cprAnalyze' (envInsert t (toVal c) env) e+            in (ELam t e',Fun val)+    cprAnalyze' env (ELam t e) = (ELam t e',Fun val) where+        (e',val) = cprAnalyze' (envInsert t Top env) e+    cprAnalyze' env ec@(ECase {}) = runWriter (caseBodiesMapM f ec) where+        f e = do+            (e',v) <- return $ cprAnalyze' env e+            tell v+            return e'+    cprAnalyze' env (EAp fun arg) = (EAp fun_cpr arg,res_res) where+        (fun_cpr, fun_res) = cprAnalyze' env fun+        res_res = case fun_res of+            Fun x -> x+            Top -> Top+            Bot -> Bot+            v -> error $ "cprAnalyze'.res_res: " ++ show v+    cprAnalyze' env  e = (e,f e) where+        f (ELit (LitInt n _)) = VInt n+        f (ELit LitCons { litName = n, litArgs = [], litType = _ }) = Tag [n]+        f (ELit LitCons { litName = n, litArgs = xs, litType = _ }) = Tup n (map g xs)+        f (EPi t e) = Tup tc_Arrow [g $ tvrType t, g e]+        f (EPrim {}) = Top -- TODO fix primitives+        f (EError {}) = Bot+        f e = error $ "cprAnalyze'.f: " ++ show e+        g = snd . cprAnalyze' env+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary Val where+    put Top = do+	    Data.Binary.putWord8 0+    put (Fun aa) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put aa+    put (Tup ab ac) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ab+	    Data.Binary.put ac+    put (VInt ad) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ad+    put (Tag ae) = do+	    Data.Binary.putWord8 4+	    Data.Binary.put ae+    put Bot = do+	    Data.Binary.putWord8 5+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Top+	      1 -> do+		    aa <- Data.Binary.get+		    return (Fun aa)+	      2 -> do+		    ab <- Data.Binary.get+		    ac <- Data.Binary.get+		    return (Tup ab ac)+	      3 -> do+		    ad <- Data.Binary.get+		    return (VInt ad)+	      4 -> do+		    ae <- Data.Binary.get+		    return (Tag ae)+	      5 -> do+		    return Bot+	      _ -> fail "invalid binary data found"++--  Imported from other files :-
+ drift_processed/E/Demand.hs view
@@ -0,0 +1,486 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/Demand.hs" #-}+module E.Demand(+    Demand(..),+    DemandSignature(..),+    DemandType(..),+    SubDemand(..),+    analyzeProgram,+    absSig,+    lazy+    ) where++import Control.Monad.Reader+import Control.Monad.Writer hiding(Product(..))+import Data.Binary+import Data.List hiding(union,delete)+import Data.Typeable++--import Debug.Trace+import DataConstructors+import Doc.DocLike+import Doc.PPrint+import E.E+import E.Program+import GenUtil+import Info.Types+import Name.Id+import Util.HasSize+import Util.SetLike+import qualified Info.Info as Info++trace _ x = x++data Demand =+    Bottom             -- always diverges+    | L !SubDemand      -- lazy+    | S !SubDemand      -- strict+    | Error !SubDemand  -- diverges, might use arguments+    | Absent           -- Not used+    deriving(Eq,Ord,Typeable)+        {-! derive: Binary !-}++data SubDemand = None | Product ![Demand]+    deriving(Eq,Ord)+        {-! derive: Binary !-}++data DemandEnv = DemandEnv !(IdMap Demand) !Demand+    deriving(Eq,Ord)+        {-! derive: Binary !-}++data DemandType = (:=>) !DemandEnv ![Demand]+    deriving(Eq,Ord)+        {-! derive: Binary !-}++data DemandSignature = DemandSignature {-# UNPACK #-} !Int !DemandType+    deriving(Eq,Ord,Typeable)+        {-! derive: Binary !-}++idGlb = Absent++absType = (DemandEnv mempty idGlb) :=> []+--botType = (DemandEnv mempty Bottom) :=> []+botType = (DemandEnv mempty Bottom) :=> []++--lazyType = (DemandEnv mempty lazy) :=> []+--lazySig = DemandSignature 0 lazyType+absSig = DemandSignature 0 absType++class Lattice a where+    glb :: a -> a -> a+    lub :: a -> a -> a++-- Sp [L .. L] = S+-- Sp [.. _|_ ..] = _|_++sp [] = S None+sp xs = S (allLazy xs) -- None++l None = L None+l (Product xs) = lp xs++s None = S None+s (Product xs) = sp xs++allLazy xs | all (== lazy) xs = None+allLazy xs = Product xs++lp [] = L None+lp xs = L (allLazy (map f xs)) where+    f (S None) = lazy+    f (S (Product ys)) = lp ys+    f Bottom = Absent+    f (Error None) = lazy+    f (Error (Product xs)) = lp xs+    f x = x++{-+sp s = sp' True s where+    sp' True [] = S None+    sp' False [] = S (Product s)+    sp' allLazy (L _:rs) = sp' allLazy rs+    sp' _ (Bottom:_) = Error (Product s)+    sp' _ (_:rs) = sp' False rs+-}++instance Lattice DemandType where+    lub (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `lub` env') :=> strictList (zipWith lub (ts ++ repeat lazy) ts')+                                    | otherwise = (env `lub` env') :=> strictList (zipWith lub ts (ts' ++ repeat lazy))+    glb (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `glb` env') :=> strictList (zipWith glb (ts ++ repeat lazy) ts')+                                    | otherwise = (env `glb` env') :=> strictList (zipWith glb ts (ts' ++ repeat lazy))++lazy = L None+strict = S None+err = Error None++strictList (x:xs) = x `seq` xs' `seq` (x:xs') where+    xs' = strictList xs+strictList [] = []++comb _ None None = None+comb f None (Product xs) = Product $ zipWith f (repeat lazy) xs+comb f (Product xs) None = Product $ zipWith f xs (repeat lazy)+comb f (Product xs) (Product ys) = Product $ zipWith f xs ys++instance Lattice Demand where+    lub Bottom s = s+    lub s Bottom = s+    lub Absent Absent = Absent+    lub (S x) Absent = l x+    lub Absent (S x) = l x+    lub (L x) Absent = l x+    lub Absent (L x) = l x+    lub Absent sa = lazy+    lub sa Absent = lazy++    lub (S x) (S y) = s (comb lub x y)+    lub (L x) (L y) = l (comb lub x y)+    lub (Error x) (Error y) = Error (comb lub x y)++    lub (S x) (L y) = l (comb lub x y)+    lub (L x) (S y) = l (comb lub x y)++    lub (S x) (Error y) = s (comb lub x y)+    lub (Error x) (S y) = s (comb lub x y)++    lub (L x) (Error y) = lazy+    lub (Error x) (L y) = lazy++    glb Bottom Bottom = Bottom+    glb Absent sa = sa+    glb sa Absent = sa++    glb Bottom _ = err+    glb _ Bottom = err++    glb (S x) (S y) = s (comb glb x y)+    glb (L x) (L y) = l (comb glb x y)+    glb (Error x) (Error y) = Error (comb glb x y)++    glb (S _) (Error _) = err+    glb (Error _) (S _) = err++    glb (S x) (L y) = s (comb glb x y)+    glb (L x) (S y) = s (comb glb x y)++    glb (L _) (Error _) = err+    glb (Error _) (L _) = err++lenv e (DemandEnv m r) = case mlookup e m of+    Nothing -> r+    Just x -> x++demandEnvSingleton :: TVr -> Demand -> DemandEnv+demandEnvSingleton _ Absent = DemandEnv mempty idGlb+demandEnvSingleton t d = DemandEnv (msingleton (tvrIdent t) d) idGlb++demandEnvMinus :: DemandEnv -> TVr -> DemandEnv+demandEnvMinus (DemandEnv m r) x = DemandEnv (delete (tvrIdent x) m) r++instance Lattice DemandEnv where+    lub d1@(DemandEnv m1 r1) d2@(DemandEnv m2 r2) = DemandEnv m (r1 `lub` r2) where+        m = fromList [ (x,lenv x d1 `lub` lenv x d2) | x <- keys (m1 `union` m2)]+    glb d1@(DemandEnv m1 r1) d2@(DemandEnv m2 r2) = DemandEnv m (r1 `glb` r2) where+        m = fromList [ (x,lenv x d1 `glb` lenv x d2) | x <- keys (m1 `union` m2)]++newtype IM a = IM (Reader (Env,DataTable) a)+    deriving(Monad,Functor,MonadReader (Env,DataTable))++type Env = IdMap (Either DemandSignature E)++getEnv :: IM Env+getEnv = asks fst++extEnv TVr { tvrIdent = i } _ | isEmptyId i = id+extEnv t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Left e) env,dt))++extEnvE TVr { tvrIdent = i } _ | isEmptyId i = id+extEnvE t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Right e) env,dt))++instance DataTableMonad IM where+    getDataTable = asks snd++runIM :: Monad m => IM a -> DataTable ->  m a+runIM (IM im) dt = return $ runReader im (mempty,dt)++-- returns the demand type and whether it was found in the local environment or guessed+determineDemandType :: TVr -> Demand -> IM (Either DemandType E)+determineDemandType tvr demand = do+    let g (DemandSignature n dt@(DemandEnv phi _ :=> _)) = f n demand where+            f 0 (S _) = dt+            f n (S (Product [s])) = f (n - 1) s+            f _ _ = lazify (DemandEnv phi Absent) :=> []+    env <- getEnv+    case mlookup (tvrIdent tvr) env of+        Just (Left ds) -> return (Left $ g ds)+        Just (Right e) -> return (Right e)+        Nothing -> case Info.lookup (tvrInfo tvr) of+            Nothing -> return (Left absType)+            Just ds -> return (Left $ g ds)++extendSig (DemandSignature n1 t1) (DemandSignature n2 t2)  = DemandSignature (max n1 n2) (glb t1 t2)++splitSigma [] = (lazy,[])+splitSigma (x:xs) = (x,xs)++analyze :: E -> Demand -> IM (E,DemandType)+analyze e Absent = return (e,absType)+analyze (EVar v) s = do+    ddt <- determineDemandType v s+    (phi :=> sigma) <- case ddt of+        Left dt -> return dt+        Right e -> liftM snd $ analyze e s+    return (EVar v,(phi `glb` (demandEnvSingleton v s)) :=> sigma)+analyze (EAp e1 e2) s = do+    (e1',phi1 :=> sigma1') <- analyze e1 (sp [s])+    let (sa,sigma1) = splitSigma sigma1'+    (e2',phi2 :=> sigma2) <- analyze e2 sa+    return $ (EAp e1' e2',(phi1 `glb` phi2) :=> sigma1)+analyze el@(ELit lc@LitCons { litName = h, litArgs = ts@(_:_) }) (S (Product ss)) | length ss == length ts = do+    dataTable <- getDataTable+    case onlyChild dataTable h of+        True -> do  -- product type+            envs <- flip mapM (zip ts ss) $ \(a,s) -> do+                (_,env :=> _) <- analyze a s+                return env+            return (el,foldr1 glb envs :=> [])+        _ -> do+            rts <- mapM (\e -> analyze e lazy) ts+            return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts))++analyze (ELit lc@LitCons { litArgs = ts }) _s = do+    rts <- mapM (\e -> analyze e lazy) ts+    return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts))+analyze e s | Just (t1,t2,pt) <- from_dependingOn e = do+    (t1',dt1) <- analyze t1 s+    (t2',dt2) <- analyze t2 lazy+    return (EPrim p_dependingOn [t1',t2'] pt,dt1 `glb` dt2)+analyze (EPrim ap ts pt) _s = do+    rts <- mapM (\e -> analyze e lazy) ts+    return (EPrim ap (fsts rts) pt, foldr glb absType (snds rts))+analyze (EPi tvr@TVr { tvrType = t1 } t2)  _s = do+    (t1',dt1) <- analyze t1 lazy+    (t2',dt2) <- analyze t2 lazy+    return (EPi tvr { tvrType = t1' } t2',dt1 `glb` dt2)++analyze (ELam x@TVr { tvrIdent = eid } e) (S (Product [s])) | eid == emptyId = do+    (e',phi :=> sigma) <- analyze e s+    let sx = Absent+    return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma))+analyze (ELam x e) (S (Product [s])) = do+    (e',phi :=> sigma) <- analyze e s+    let sx = lenv (tvrIdent x) phi+    return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma))++analyze (ELam x e) (L (Product [s])) = do+    (e',phi :=> sigma) <- analyze e s+    let sx = lenv (tvrIdent x) phi+    return (ELam (tvrInfo_u (Info.insert $! sx) x) e',lazify (demandEnvMinus phi x) :=> (sx:sigma))+analyze (ELam x e) (S None) = analyze (ELam x e) (S (Product [lazy]))  -- simply to ensure binder is annotated+analyze (ELam x e) (L None) = analyze (ELam x e) (L (Product [lazy]))  -- simply to ensure binder is annotated+analyze (ELam x e) (Error None) = analyze (ELam x e) (Error (Product [lazy]))  -- simply to ensure binder is annotated+analyze e@EError {} (S _) = return (e,botType)+analyze e@EError {} (L _) = return (e,absType)+analyze ec@ECase { eCaseBind = b, eCaseAlts = [Alt lc@LitCons { litName = h, litArgs = ts } alt], eCaseDefault = Nothing } s = do+    dataTable <- getDataTable+    case onlyChild dataTable h of+        True -> do  -- product type+            (alt',enva :=> siga) <- extEnvE b (eCaseScrutinee ec) $ analyze alt s+            (e',enve :=> []) <- analyze (eCaseScrutinee ec) (sp [ lenv (tvrIdent t) enva | t <- ts])+            let nenv = enve `glb` foldr denvDelete enva (b:ts)+            return (caseUpdate $ ec { eCaseScrutinee = e', eCaseAlts = [Alt lc alt'] }, nenv :=> siga)+        _ -> analyzeCase ec s+analyze ec@ECase {} s = analyzeCase ec s+analyze ELetRec { eDefs = ds, eBody = b } s = f (decomposeDs ds) [] where+    f [] ds' = do+        (b',phi :=> sig) <- analyze b s+        let g (t,e) = (tvrInfo_u (Info.insert $! (lenv (tvrIdent t) phi)) t,e)+        return (ELetRec (map g ds') b', foldr denvDelete phi (fsts ds) :=> sig)+    f (Left (t,e):rs) fs =+        solveDs' (Just False) [(t,e)] fixupDemandSignature (\nn -> f rs (nn ++ fs))+    f (Right rg:rs) fs = do+        solveDs' (Just True) rg fixupDemandSignature (\nn -> f rs (nn ++ fs))+analyze Unknown _ = return (Unknown,absType)+analyze es@ESort {} _ = return (es,absType)+analyze es@(ELit LitInt {}) _ = return (es,absType)+analyze e x = fail $ "analyze: " ++ show (e,x)++from_dependingOn (EPrim don [t1,t2] pt) | don == p_dependingOn = return (t1,t2,pt)+from_dependingOn _ = fail "not dependingOn"++lazify (DemandEnv x r) = DemandEnv (fmap f x) Absent where+    f (S xs) = l xs+    f Absent = Absent+    f (L xs) = l xs+    f Bottom = Absent+    f (Error xs) = l xs++analyzeCase ec s = do+    (ec',dts) <- extEnvE (eCaseBind ec) (eCaseScrutinee ec) $ runWriterT $ flip caseBodiesMapM ec $ \e -> do+        (ne,dt) <- lift $ analyze e s+        tell [dt]+        return ne+    (ecs,env :=> _) <- analyze (eCaseScrutinee ec') strict+    let enva :=> siga =  foldr1 lub dts+    let nenv = foldr denvDelete (glb enva env) (caseBinds ec')+    return (caseUpdate $ ec' {eCaseScrutinee = ecs},nenv :=> siga)++denvDelete x (DemandEnv m r) = DemandEnv (delete (tvrIdent x) m) r++topAnalyze :: TVr -> E -> IM (E,DemandSignature)+topAnalyze tvr e | getProperty prop_PLACEHOLDER tvr = return (e,DemandSignature 0 absType)+topAnalyze _tvr e = clam e strict 0 where+    clam (ELam _ x) s n = clam x (sp [s]) (n + 1)+    clam _ s n = do+        (e,dt) <- analyze e s+        return (e,DemandSignature n dt)++fixupDemandSignature (DemandSignature n (DemandEnv _ r :=> dt)) = DemandSignature n (DemandEnv mempty r :=> dt)++shouldBind ELit {} = True+shouldBind EVar {} = True+shouldBind EPi {} = True+shouldBind _ = False++solveDs' :: (Maybe Bool) -> [(TVr,E)] -> (DemandSignature -> DemandSignature) -> ([(TVr,E)] -> IM a) -> IM a+solveDs' Nothing ds fixup wdone = do+    let f (Left d:rs) xs = solveDs' (Just False) [d] fixup (\nds -> f rs (nds ++ xs))+        f (Right ds:rs) xs = solveDs' (Just True) ds fixup (\nds -> f rs (nds ++ xs))+        f [] xs = wdone xs+    f (decomposeDs ds) []+solveDs' (Just False) [(t,e)] fixup wdone | shouldBind e = do+    (ne,ds) <- topAnalyze t e+    extEnvE t e $ wdone [(tvrInfo_u (Info.insert (fixup ds)) t,ne)]+solveDs' (Just False) [(t,e)] fixup wdone = do+    (ne,ds) <- topAnalyze t e+    extEnv t ds $ wdone [(tvrInfo_u (Info.insert (fixup ds)) t,ne)]+--solveDs' (Just False) ds fixup wdone = solveDs' Nothing ds fixup wdone+solveDs' (Just False) ds fixup wdone = error "solveDs' (Just False) called with more than one definition"+solveDs' (Just True) ds fixup wdone = trace "solveDs': jt" $ do+    let ds' = [ ((t,e),sig) | (t,e) <- ds, let sig = maybe absSig id (Info.lookup (tvrInfo t))]+        g 0 _ [] ds = trace "gdonetout" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ]+        g _ False [] ds = trace "gdone1" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ]+        g n True [] ds = do+            (oe,dt) <- ask+            let nenv = fromList [ (tvrIdent t,Left s) |  ((t,_),s) <- ds, not (isEmptyId (tvrIdent t))] `Util.SetLike.union` oe+            local (const (nenv,dt)) $ trace ("grepeating: " ++ show (length ds)) $ g (n - 1) False ds []+        g n ch (((t,e),sig):rs) fs = do+            (ne,sig') <- topAnalyze t e+            let sig'' = sig `extendSig` sig'+            --(if sig'' /= sig then trace ("signe: " ++ show(tvrIdent t,sig)) else id) $+            g n (ch || (sig'' /= sig)) rs (((t,ne),sig''):fs)+    g (5::Int) True [] ds'++{-# NOINLINE analyzeProgram #-}+analyzeProgram prog = do+    let ds = programDs prog+    nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) (progDataTable prog)+    --flip mapM_ nds $ \ (t,_) ->+    --    putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t))+    return $ programSetDs' nds prog++----------------------------+-- show and pprint instances+----------------------------++instance Show Demand where+    showsPrec _ Bottom = ("_|_" ++)+    showsPrec _ Absent = ('A':)+    showsPrec _ (L None) = ('L':)+    showsPrec _ (L (Product ds)) = showString "L(" . foldr (.) id (map shows ds) . showString ")"+    showsPrec _ (S None) = ('S':)+    showsPrec _ (S (Product ds)) = showString "S(" . foldr (.) id (map shows ds) . showString ")"+    showsPrec _ (Error None) = showString "Err"+    showsPrec _ (Error (Product ds)) = showString "Err(" . foldr (.) id (map shows ds) . showString ")"++instance DocLike d => PPrint d Demand where+    pprint demand = tshow demand++instance Show DemandType where+    showsPrec _ (DemandEnv e Absent :=> d) | isEmpty e = shows d+    showsPrec _ (env :=> ds) = shows env . showString " :=> " .  shows ds++instance Show DemandEnv where+    showsPrec _ (DemandEnv m Absent) = showString "{" . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}"+    showsPrec _ (DemandEnv _ Bottom) = showString "_|_"+    showsPrec _ (DemandEnv m demand) = showString "{" . shows demand . showString " - " . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}"++instance Show DemandSignature where+    showsPrec _ (DemandSignature n dt) = showString "<" . shows n . showString "," . shows dt . showString ">"+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary Demand where+    put Bottom = do+	    Data.Binary.putWord8 0+    put (L aa) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put aa+    put (S ab) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ab+    put (Error ac) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ac+    put Absent = do+	    Data.Binary.putWord8 4+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Bottom+	      1 -> do+		    aa <- Data.Binary.get+		    return (L aa)+	      2 -> do+		    ab <- Data.Binary.get+		    return (S ab)+	      3 -> do+		    ac <- Data.Binary.get+		    return (Error ac)+	      4 -> do+		    return Absent+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary SubDemand where+    put None = do+	    Data.Binary.putWord8 0+    put (Product aa) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put aa+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return None+	      1 -> do+		    aa <- Data.Binary.get+		    return (Product aa)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary DemandEnv where+    put (DemandEnv aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (DemandEnv aa ab)++instance Data.Binary.Binary DemandType where+    put ((:=>) aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return ((:=>) aa ab)++instance Data.Binary.Binary DemandSignature where+    put (DemandSignature aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (DemandSignature aa ab)++--  Imported from other files :-
+ drift_processed/E/LambdaLift.hs view
@@ -0,0 +1,349 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/LambdaLift.hs" #-}+module E.LambdaLift(lambdaLift,staticArgumentTransform)  where++import Control.Monad.Reader+import Control.Monad.Writer+import Data.IORef+import Data.Maybe+import Text.Printf++import Doc.PPrint+import E.Annotate+import E.E+import E.Inline+import E.Program+import E.Subst+import E.Traverse+import E.TypeCheck+import E.Values+import Fixer.Fixer+import Fixer.Supply+import GenUtil+import Name.Id+import Name.Name+import Options (verbose)+import Stats(mtick,runStatM,runStatT)+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Graph as G+import Util.HasSize+import Util.SetLike hiding(Value)+import Util.UniqueMonad++annotateId mn x = case fromId x of+    Just y -> toId (toName Val (mn,'f':show y))+    Nothing -> toId (toName Val (mn,'f':show x))++-- | transform simple recursive functions into non-recursive variants+-- this is exactly the opposite of lambda lifting, but is a big win if the function ends up inlined+-- and is conducive to other optimizations+--+-- in particular, the type arguments can almost always be transformed away from the recursive inner function+--+-- this has potentially exponential behavior. beware++staticArgumentTransform :: Program -> Program+staticArgumentTransform prog = ans where+    ans = progCombinators_s (concat ds') prog { progStats = progStats prog `mappend` nstat }+    (ds',nstat) = runStatM $ mapM h (programDecomposedCombs prog)+    h (True,[comb]) = do [(_,nb)] <- f True (Right [(combHead comb, combBody comb)]); return [combBody_s nb comb]+    h (_,cs) = do+        forM cs $ \ c -> do+            e' <- g (combBody c)+            return (combBody_s e' c)+    f _ (Left (t,e)) = gds [(t,e)]+    f always (Right [(t,v@ELam {})]) | not (null collectApps), always || dropArgs > 0 = ans where+        nname = annotateId "R@" (tvrIdent t)+        dropArgs = minimum [ countCommon args aps | aps <- collectApps ] where+            args = map EVar $ snd $ fromLam v+            countCommon (x:xs) (y:ys) | x == y = 1 + countCommon xs ys+            countCommon _ _ = 0+        collectApps = execWriter (ca v) where+            ca e | (EVar v,as) <- fromAp e, tvrIdent v == tvrIdent t = tell [as] >> mapM_ ca as >> return e+            ca e = emapE ca e+        (body,args) = fromLam v+        (droppedAs,keptAs) = splitAt dropArgs args+        rbody = foldr ELam (subst t newV body)  keptAs+        newV = foldr ELam (EVar tvr') [ t { tvrIdent = emptyId } | t <- droppedAs ]+        tvr' = tvr { tvrIdent = nname, tvrType = getType rbody }+        ne' = foldr ELam (ELetRec [(tvr',rbody)]  (foldl EAp (EVar tvr') (map EVar keptAs))) args+        ans = do+            mtick $ "SimpleRecursive.{" ++ pprint t+            ne' <- g ne'+            return [(t,ne')]+    f _ (Right ts) =  gds ts+    gds ts = mapM g' ts >>= return where+        g' (t,e) = g e >>= return . (,) t+    g elet@ELetRec { eDefs = ds } =  do+        ds'' <- mapM (f False) (decomposeDs ds)+        e' <- g $ eBody elet+        return elet { eDefs = concat ds'', eBody = e' }+    g e = emapE g e++data S = S {+    funcName :: Name,+    topVars :: IdSet,+    isStrict :: Bool,+    declEnv :: [(TVr,E)]+    }++isStrict_u f r@S{isStrict  = x} = r{isStrict = f x}+topVars_u f r@S{topVars  = x} = r{topVars = f x}+isStrict_s v =  isStrict_u  (const v)++{-+etaReduce :: E -> (E,Int)+etaReduce e = case f e 0 of+        (ELam {},_) -> (e,0)+        x -> x+    where+        f (ELam t (EAp x (EVar t'))) n | n `seq` True, t == t' && not (tvrIdent t `member` (freeVars x :: IdSet)) = f x (n + 1)+        f e n = (e,n)+-}++-- | we do not lift functions that only appear in saturated strict contexts,+-- as these functions will never have an escaping thunk or partial app+-- built and can be turned into local functions in grin.+--+-- Although grin is only able to take advantage of groups of possibily+-- mutually recursive local functions that only tail-call each other, we leave+-- all candidate functions local, as further grin transformations can expose+-- tail-calls that arn't evident in core.+--+-- A final lambda-lifting needs to be done in grin to get rid of these local+-- functions that cannot be turned into loops++calculateLiftees :: Program -> IO IdSet+calculateLiftees prog = do+    fixer <- newFixer+    sup <- newSupply fixer++    let f v env ELetRec { eDefs = ds, eBody = e } = do+            let nenv = fromList [ (tvrIdent t,length (snd (fromLam e))) | (t,e) <- ds ]  `mappend` env+                nenv :: IdMap Int+                g (t,e@ELam {}) = do+                    v <- supplyValue sup (tvrIdent t)+                    let (a,_as) = fromLam e+                    f v nenv a+                g (t,e) = do+                    f (value True) nenv e+            mapM_ g ds+            f v nenv e+        f v env e@ESort {} = return ()+        f v env e@Unknown {} = return ()+        f v env e@EError {} = return ()+        f v env (EVar TVr { tvrIdent = vv }) = do+            nv <- supplyValue sup vv+            assert nv+        f v env e | (EVar TVr { tvrIdent = vv }, as@(_:_)) <- fromAp e, Just n <- mlookup vv env = do+            nv <- supplyValue sup vv+            if length as >= n then v `implies` nv else assert nv+            mapM_ (f (value True) env) as+        f v env e | (a, as@(_:_)) <- fromAp e = do+            mapM_ (f (value True) env) as+            f v env a+        f v env (ELit LitCons { litArgs = as }) = mapM_ (f (value True) env) as+        f v env ELit {} = return ()+        f v env (EPi TVr { tvrType = a } b) = f (value True) env a >> f (value True) env b+        f v env (EPrim _ as _) = mapM_ (f (value True) env) as+        f v env ec@ECase {} = do+            f v env (eCaseScrutinee ec)+            mapM_ (f v env) (caseBodies ec)+        f v env (ELam _ e) = f (value True) env e+        f _ _ EAp {} = error "this should not happen"+    mapM_ (f (value False) mempty) [ fst (fromLam e) | (_,e) <- programDs prog]++    findFixpoint Nothing {-"Liftees"-} fixer+    vs <- supplyReadValues sup+    let nlset =  (fromList [ x | (x,False) <- vs])+    when verbose $ printf "%d lambdas not lifted\n" (size nlset)+    return nlset++implies :: Value Bool -> Value Bool -> IO ()+implies x y = addRule $ y `isSuperSetOf` x++assert x = value True `implies` x++lambdaLift ::  Program -> IO Program+lambdaLift prog@Program { progDataTable = dataTable, progCombinators = cs } = do+    noLift <- calculateLiftees prog+    let wp =  fromList [ combIdent x | x <- cs ] :: IdSet+    fc <- newIORef []+    fm <- newIORef mempty+    statRef <- newIORef mempty+    let z comb  = do+            (n,as,v) <- return $ combTriple comb+            let ((v',(cs',rm)),stat) = runReader (runStatT $ execUniqT 1 $ runWriterT (f v)) S { funcName = mkFuncName (tvrIdent n), topVars = wp,isStrict = True, declEnv = [] }+            modifyIORef statRef (mappend stat)+            modifyIORef fc (\xs -> combTriple_s (n,as,v') comb:cs' ++ xs)+            modifyIORef fm (rm `mappend`)+        shouldLift t _ | tvrIdent t `member` noLift = False+        shouldLift _ ECase {} = True+        shouldLift _ ELam {} = True+        shouldLift _ _ = False+        f e@(ELetRec ds _)  = do+            let (ds',e') = decomposeLet e+            h ds' e' []+        f e = do+            st <- asks isStrict+            if ((tvrIdent tvr `notMember` noLift && isELam e) || (shouldLift tvr e && not st)) then do+                (e,fvs'') <- pLift e+                doBigLift e fvs'' return+             else g e+        -- This ensures there are no 'orphaned type terms' when something is+        -- lifted out.  The problem occurs when a type is subsituted in some+        -- places and not others, the type as free variable will not be the+        -- same as its substituted instances if the variable is bound by a+        -- lambda, Although the program is still typesafe, it is no longer+        -- easily proven so, so we avoid the whole mess by subtituting known+        -- type variables within lifted expressions. This can not duplicate work+        -- since types are unpointed, but might change space usage slightly.+--        g ec@ECase { eCaseScrutinee = (EVar v), eCaseAlts = as, eCaseDefault = d} | sortKindLike (tvrType v) = do+--            True <- asks isStrict+--            d' <- fmapM f d+--            let z (Alt l e) = do+--                    e' <- local (declEnv_u ((v,followAliases dataTable $ patToLitEE l):)) $ f e+--                    return $ Alt l e'+--            as' <- mapM z as+--            return $ caseUpdate ec { eCaseAlts = as', eCaseDefault = d'}+        g (ELam t e) = do+            e' <- local (isStrict_s True) (g e)+            return (ELam t e')+        g e = emapE' f e+        pLift e = do+            gs <- asks topVars+            ds <- asks declEnv+            let fvs = freeVars e+                fvs' = filter (not . (`member` gs) . tvrIdent) fvs+                --ss = filter (sortKindLike . tvrType) fvs'+                ss = []+                f [] e False = return (e,fvs'')+                f [] e True = pLift e+                f (s:ss) e x+                    | Just v <- lookup s ds = f ss (removeType s v e) True   -- TODO subst+                    | otherwise = f ss e x+                fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars+            f ss e False+        h (Left (t,e):ds) rest ds' | shouldLift t e = do+            (e,fvs'') <- pLift e+            case fvs'' of+                [] -> doLift t e (h ds rest ds')+                fs -> doBigLift e fs (\e'' -> h ds rest ((t,e''):ds'))+        h (Left (t,e@ELam {}):ds) rest ds' = do+            let (a,as) = fromLam e+            a' <- local (isStrict_s True) (f a)+            h ds rest ((t,foldr ELam a' as):ds')++        h (Left (t,e):ds) rest ds'  = do+            let fvs =  freeVars e :: [Id]+            gs <- asks topVars+            let fvs' = filter (not . (`member` gs) ) fvs+            case fvs' of+                [] -> doLift t e (h ds rest ds')  -- We always lift CAFS to the top level for now. (GC?)+                _ ->  local (isStrict_s False) (f e) >>= \e'' -> h ds rest ((t,e''):ds')+        --h (Left (t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds')+        h (Right rs:ds) rest ds' | any (uncurry shouldLift) rs  = do+            gs <- asks topVars+            let fvs =  freeVars (snds rs)--   (Set.fromList (map tvrIdent $ fsts rs) `Set.union` gs)+            let fvs' = filter (not . (`member` (fromList (map tvrIdent $ fsts rs) `mappend` gs) ) . tvrIdent) fvs+                fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars+            case fvs'' of+                [] -> doLiftR rs (h ds rest ds')  -- We always lift CAFS to the top level for now. (GC?)+                fs -> doBigLiftR rs fs (\rs' -> h ds rest (rs' ++ ds'))+        h (Right rs:ds) e' ds'   = do+            rs' <- local (isStrict_s False) $ do+                flip mapM rs $ \te -> case te of+                    (t,e@ELam {}) -> do+                        let (a,as) = fromLam e+                        a' <- local (isStrict_s True) (f a)+                        return (t,foldr ELam a' as)+                    (t,e) -> do+                        e'' <- f e+                        return (t,e'')+            h ds e' (rs' ++ ds')+        h [] e ds = f e >>= return . eLetRec ds+        tellCombinator c = tell ([combTriple_s c emptyComb],mempty)+        tellCombinators c = tell (map (`combTriple_s` emptyComb) c,mempty)+        doLift t e r = local (topVars_u (insert (tvrIdent t)) ) $ do+            --(e,tn) <- return $ etaReduce e+            let (e',ls) = fromLam e+            mtick (toAtom $ "E.LambdaLift.doLift." ++ typeLift e ++ "." ++ show (length ls))+            --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")+            e'' <- local (isStrict_s True) $ f e'+            t <- globalName t+            tellCombinator (t,ls,e'')+            r+        doLiftR rs r = local (topVars_u (mappend (fromList (map (tvrIdent . fst) rs)) )) $ do+            flip mapM_ rs $ \ (t,e) -> do+                --(e,tn) <- return $ etaReduce e+                let (e',ls) = fromLam e+                mtick (toAtom $ "E.LambdaLift.doLiftR." ++ typeLift e ++ "." ++ show (length ls))+                --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")+                e'' <- local (isStrict_s True) $ f e'+                t <- globalName t+                tellCombinator (t,ls,e'')+            r+        globalName tvr | isNothing $ fromId (tvrIdent tvr) = do+            TVr { tvrIdent = t } <- newName Unknown+            let ntvr = tvr { tvrIdent = t }+            tell ([],msingleton (tvrIdent tvr) (Just $ EVar ntvr))+            return ntvr+        globalName tvr = return tvr+        newName tt = do+            un <-  newUniq+            n <- asks funcName+            return $ tVr (toId $ mapName (id,(++ ('$':show un))) n) tt+        doBigLift e fs  dr = do+            mtick (toAtom $ "E.LambdaLift.doBigLift." ++ typeLift e ++ "." ++ show (length fs))+            ds <- asks declEnv+            let tt = typeInfer' dataTable ds (foldr ELam e fs)+            tvr <- newName tt+            let (e',ls) = fromLam e+            e'' <- local (isStrict_s True) $ f e'+            tellCombinator (tvr,fs ++ ls,e'')+            let e'' = foldl EAp (EVar tvr) (map EVar fs)+            dr e''+        doBigLiftR rs fs dr = do+            ds <- asks declEnv+            rst <- flip mapM rs $ \ (t,e) -> do+                case shouldLift t e of+                    True -> do+                        mtick (toAtom $ "E.LambdaLift.doBigLiftR." ++ typeLift e ++ "." ++ show (length fs))+                        let tt = typeInfer' dataTable ds (foldr ELam e fs)+                        tvr <- newName tt+                        let (e',ls) = fromLam e+                        e'' <- local (isStrict_s True) $ f e'+                        --tell [(tvr,fs ++ ls,e'')]+                        let e''' = foldl EAp (EVar tvr) (map EVar fs)+                        return ((t,e'''),[(tvr,fs ++ ls,e'')])+                    False -> do+                        mtick (toAtom $ "E.LambdaLift.skipBigLiftR." ++ show (length fs))+                        return ((t,e),[])+            let (rs',ts) = unzip rst+            tellCombinators [ (t,ls,substLet rs' e) | (t,ls,e) <- concat ts]+            dr rs'++        mkFuncName x = case fromId x of+            Just y -> y+            Nothing -> toName Val ("LL@",'f':show x)+    mapM_ z cs+    ncs <- readIORef fc+    nstat <- readIORef statRef+    nz <- readIORef fm+    annotateProgram nz (\_ nfo -> return nfo) (\_ nfo -> return nfo) (\_ nfo -> return nfo) prog { progCombinators =  ncs, progStats = progStats prog `mappend` nstat }++typeLift ECase {} = "Case"+typeLift ELam {} = "Lambda"+typeLift _ = "Other"++removeType t v e  = subst' t v e+{-+removeType t v e = ans where+    (b,ls) = fromLam e+    ans = foldr f (substLet [(t,v)] e) ls+    f tv@(TVr { tvrType = ty} ) e = ELam nt (subst tv (EVar nt) e) where nt = tv { tvrType = (subst t v ty) }+-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+--  Imported from other files :-
+ drift_processed/E/SSimplify.hs view
@@ -0,0 +1,1090 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/SSimplify.hs" #-}+module E.SSimplify(+    Occurance(..),+    cacheSimpOpts,+    simplifyE,+    collectOccurance',+    programPruneOccurance,+    programSSimplify,+    programSSimplifyPStat,+    SimplifyOpts(..),+    emptySimplifyOpts+    ) where++import Control.Monad.Identity+import Data.Maybe+import Data.Typeable+import Debug.Trace+import Data.List hiding(delete,union,insert)+import qualified Data.Set as Set+import qualified Data.Traversable as T++import C.Prims+import Cmm.Number+import DataConstructors+import Doc.PPrint+import E.E+import E.Eta+import E.Inline+import E.PrimOpt+import E.Program+import E.Rules+import E.Subst+--import E.Traverse(runRename)+import E.TypeCheck+import E.Values+import GenUtil hiding (split)+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import Name.VConsts+import Options+import Stats hiding(null,new,print,Stats,singleton)+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Graph+import Util.HasSize+import Util.NameMonad+import Util.RWS+import Util.ReaderWriter+import Util.SetLike as S+import qualified E.Demand as Demand+import qualified FlagDump as FD+import qualified FlagOpts as FO+import qualified Info.Info as Info++--type Bind = (TVr,E)++data Occurance =+    Unused        -- ^ unused means a var is not used at the term level, but might be at the type level+    | Once        -- ^ Used at most once not inside a lambda or as an argument+    | OnceInLam   -- ^ used once inside a lambda+    | ManyBranch  -- ^ used once in several branches+    | Many        -- ^ used many or an unknown number of times+    | LoopBreaker -- ^ chosen as a loopbreaker, never inline+    deriving(Show,Eq,Ord)++data UseInfo = UseInfo {+    useOccurance :: !Occurance,   -- ^ occurance Info+    minimumArgs  :: {-# UNPACK #-} !Int          -- ^ minimum number of args that are ever passed to this function (if used)+    }+    deriving(Show,Eq,Ord,Typeable)++noUseInfo = UseInfo { useOccurance = Many, minimumArgs = 0 }+notUsedInfo = UseInfo { useOccurance = Unused, minimumArgs = maxBound }++programPruneOccurance :: Program -> Program+programPruneOccurance prog =+    let dsIn = progCombinators prog -- (runIdentity $ programMapBodies (return . subst (tVr (-1) Unknown) Unknown) prog)+        (dsIn',(OMap fvs,uids)) = runReaderWriter (unOM $ collectDs dsIn mempty) (progEntry prog)+    in --trace ("dsIn: "++show (length dsIn)) $+       (progCombinators_s dsIn' prog) { progFreeIds = idMapToIdSet fvs, progUsedIds = uids }++newtype OM a = OM (ReaderWriter IdSet (OMap,IdSet) a)+    deriving(Monad,Functor,MonadWriter (OMap,IdSet),MonadReader IdSet)++unOM (OM a) = a++newtype OMap = OMap (IdMap UseInfo)+   deriving(HasSize,Collection,Unionize,SetLike,MapLike,Show,IsEmpty,Eq,Ord)++type instance Value OMap = UseInfo+type instance Key OMap = Id+type instance Elem OMap = (Key OMap,Value OMap)++instance Monoid OMap where+    mempty = OMap mempty+    mappend (OMap a) (OMap b) = OMap (andOM a b)++maybeLetRec [] e = e+maybeLetRec ds e = ELetRec ds e++-- | occurance analysis++grump :: OM a -> OM (a,OMap)+grump m = fmap ( \ (x, (y,z)) -> (x,y) ) $ censor (\ (_,y) -> (mempty,y)) (listen m)++collectOccurance' :: E -> (E,IdMap UseInfo)+collectOccurance' e = (fe,omap) where+    (fe,(OMap omap,_)) = runReaderWriter (unOM $ collectOccurance e) mempty++collectOccurance :: E -> OM E -- ^ (annotated expression, free variables mapped to their occurance info)+collectOccurance e = f e where+    f e@ESort {} = return e+    f e@Unknown {} = return e+    f (EPi tvr@TVr { tvrIdent = eid, tvrType =  a} b) | isEmptyId eid = arg $ do+        a <- f a+        b <- f b+        return (EPi tvr { tvrType = a } b)+    f (EPi tvr@(TVr { tvrIdent = n, tvrType =  a}) b) = arg $ do+        a <- f a+        (b,tfvs) <- grump (f b)+        case mlookup n tfvs of+            Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = emptyId, tvrType = a } b)+            Just occ -> tell (delete n tfvs,singleton n) >> return (EPi (annb' tvr { tvrType = a }) b)+    f (ELit lc@LitCons { litArgs = as, litType = t }) = arg $ do+        t <- f t+        as <- mapM f as+        return (ELit lc { litArgs = as, litType = t })+    f (ELit (LitInt i t)) = do+        t <- arg (f t)+        return $ ELit (LitInt i t)+    f (EPrim p as t) = arg $ do+        t <- f t+        as <- mapM f as+        return (EPrim p as t)+    f (EError err t) = do+        t <- arg (f t)+        return $ EError err t+    f e | (b,as@(_:_)) <- fromLam e = do+        (b',bvs) <- grump (f b)+        (as',asfv) <- grump (arg $ mapM ftvr as)+        let avs = bvs `andOM` asfv+            as'' = map (annbind' avs) as'+        case all (getProperty prop_ONESHOT) as of+            True ->  tell $ (foldr delete avs (map tvrIdent as),fromList $ map tvrIdent as)+            False -> tell $ (inLam $ foldr delete avs (map tvrIdent as),fromList $ map tvrIdent as)+        return (foldr ELam b' as'')+    f e | Just (x,t) <- from_unsafeCoerce e  = do x <- f x ; t <- (arg (f t)); return (prim_unsafeCoerce x t)+    f (EVar tvr@TVr { tvrIdent = n, tvrType =  t}) = do+        tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = 0 },mempty)+        t <- arg (f t)+        return $ EVar tvr { tvrType = t }+    f e | (EVar tvr@TVr { tvrIdent = n, tvrType = t},xs@(_:_)) <- fromAp e = do+        tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = length xs },mempty)+        t <- arg (f t)+        xs <- arg (mapM f xs)+        return (foldl EAp (EVar tvr { tvrType = t}) xs)+    f e | (x,xs@(_:_)) <- fromAp e = do+        x <- f x+        xs <- arg (mapM f xs)+        return (foldl EAp x xs)+    f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do+        scrut' <- f e+        (d',fvb) <- grump (T.mapM f d)+        (as',fvas) <- mapAndUnzipM (grump . alt) as+        let fidm = orMaps (fvb:fvas)+        ct <- arg $ f (eCaseType ec)+        b <- arg (ftvr b)+        tell $ (delete (tvrIdent b) fidm,singleton (tvrIdent b))+        return $ caseUpdate ec { eCaseScrutinee = scrut', eCaseAlts = as',+            eCaseBind = annbind' fidm b, eCaseType = ct, eCaseDefault = d'}+    f ELetRec { eDefs = ds, eBody = e } = do+        (e',fve) <- grump (f e)+        ds''' <- collectDs (map bindComb ds) fve+        return (maybeLetRec (map combBind ds''') e')+    f e = error $ "SSimplify.collectOcc.f: " ++ show e+    alt (Alt l e) = do+        (e',fvs) <- grump (f e)+        l <- arg (mapLitBindsM ftvr l)+        l <- arg (T.mapM f l)+        let fvs' = foldr delete fvs (map tvrIdent $ litBinds l)+            l' = mapLitBinds (annbind' fvs) l+        tell (fvs',fromList $ map tvrIdent (litBinds l'))+        return (Alt l' e')+    arg m = do+        let mm (OMap mp,y) = (OMap $ fmap (const noUseInfo) mp,y)+        censor mm m+    ftvr tvr = do+        tt <- f (tvrType tvr)+        return tvr { tvrType = tt }++-- delete any occurance info for non-let-bound vars to be safe+annb' tvr = tvrInfo_u (Info.delete noUseInfo) tvr+annbind' idm tvr = case mlookup (tvrIdent tvr) idm of+    Nothing | sortTermLike (getType tvr) -> annb' tvr { tvrIdent = emptyId }+    _ -> annb' tvr++-- add ocucrance info+annbind idm tvr = case mlookup (tvrIdent tvr) idm of+    Nothing -> annb notUsedInfo tvr { tvrIdent = emptyId }+    Just x -> annb x tvr+annb x tvr = tvrInfo_u (Info.insert x) tvr++mapLitBinds f lc@LitCons { litArgs = es } = lc { litArgs = map f es }+mapLitBinds f (LitInt e t) = LitInt e t+mapLitBindsM f lc@LitCons { litArgs = es } = do+    es <- mapM f es+    return lc { litArgs = es }+mapLitBindsM f (LitInt e t) = return $  LitInt e t++collectBinding :: Comb -> OM (Comb,OMap)+collectBinding comb = do+    e' <- collectOccurance $ combBody comb+    let rvars = freeVars (combRules comb)  :: IdSet+        romap = OMap (idSetToIdMap (const noUseInfo) rvars)+    return (combBody_s e' comb,romap)++unOMap (OMap x) = x++--collectCombs :: [Comb] -> OMap -> OM [Comb]+--collectCombs cs _ = return cs++collectDs :: [Comb] -> OMap -> OM [Comb]+collectDs ds (OMap fve) = do+    ds' <- mapM (grump . collectBinding) ds+    exp <- ask+    let (reachable',_) = newGraphReachable ds' (\ ((comb,_),_) -> combIdent comb) (\ ((_,rv),fv) -> keys (fv `mappend` rv))+        rds = reachable' (keys fve ++ [ combIdent t | t <- ds,  (combIdent t `member` exp)])+        -- ignore rules when calculating loopbreakers+        -- we must not simplify the expanded body of a rule without recalculating occurance info.+        graph' = newGraph rds (\ ((comb,_),_) -> combIdent comb) (\ (_,fv) -> keys fv)+        (lb,lbds) =  findLoopBreakers (\ ((comb,_),_) -> loopFunc (combHead comb) (combBody comb)) canBeLoopBreaker graph'+        canBeLoopBreaker n = not $ getProperty prop_WRAPPER (fst $ fst $ n)+        ds'' = map ( \ ((t,rv),rv') -> (t,rv `mappend` rv') ) lbds+        fids = foldl andOM mempty (fve:map unOMap (snds ds''))+        ffids = fromList [ (tvrIdent t,lup t) | (Comb { combHead = t },_) <- ds'' ]+        cycNodes = (fromList $ [ combIdent c | ((c,_),_) <- cyclicNodes graph'] :: IdSet)+        calcStrictInfo :: TVr -> TVr+        calcStrictInfo t+            | tvrIdent t `member` cycNodes = setProperty prop_CYCLIC t+            | otherwise = t+        lup t = case tvrIdent t `elem` [ combIdent c | ((c,_),_) <- lb] of+            True -> noUseInfo { useOccurance = LoopBreaker }+            False -> case  (tvrIdent t `member` exp) of+                True -> noUseInfo+                False | Just r <- mlookup (tvrIdent t) fids -> r+                _ -> error "SSimplify.collectDs: bad."+        ds''' = [ combHead_s (calcStrictInfo $ annbind ffids (combHead comb)) comb | (comb,_) <- ds'']+        froo comb = (combHead_s (combHead comb) {tvrType = t' } comb,fvs) where+            (t',fvs) = collectOccurance' (tvrType $ combHead comb)+        (ds'''',nfids) = unzip $ map froo ds'''+        nfid' = fmap (const noUseInfo) (mconcat nfids)+    tell $ ((OMap $ nfid' `andOM` fids) S.\\ ffids,fromList (map combIdent ds''''))+    return (ds'''')++-- TODO this should use the occurance info+-- loopFunc t _ | getProperty prop_PLACEHOLDER t = -100  -- we must not choose the placeholder as the loopbreaker+loopFunc t e = negate (baseInlinability t e)++inLam (OMap om) = OMap (fmap il om) where+    il ui@UseInfo { useOccurance = Once } = ui { useOccurance = OnceInLam }+    il ui = ui { useOccurance = Many }++--andOM :: IdMap UseInfo -> IdMap UseInfo -> IdMap UseInfo+andOM x y = unionWith andOcc x y+andOcc UseInfo { useOccurance = Unused } x = x+andOcc x UseInfo { useOccurance = Unused } = x+andOcc x y = UseInfo { useOccurance = Many,+    minimumArgs = min (minimumArgs x) (minimumArgs y) }++orMaps ms = OMap $ fmap orMany $ foldl (unionWith (++)) mempty (map (fmap (:[]))+    (map unOMap ms)) where unOMap (OMap m) = m++orMany [] = error "empty orMany"+orMany xs = f (filter ((/= Unused) . useOccurance) xs) where+    f [] = notUsedInfo+    f [x] = x+    f xs = if all good (map useOccurance xs) then ui ManyBranch else ui Many where+        good Once = True+        good ManyBranch = True+        good _ = False+        ui x = UseInfo { minimumArgs =  minimum (map minimumArgs xs), useOccurance = x }++data SimplifyOpts = SimpOpts {+    so_noInlining :: !Bool, -- ^ this inhibits all inlining inside functions which will always be inlined+    so_finalPhase :: !Bool, -- ^ no rules and don't inhibit inlining+    so_postLift   :: !Bool, -- ^ don't inline anything that was lifted out+    so_boundVars :: IdMap Comb,            -- ^ bound variables+    so_forwardVars :: IdSet,               -- ^ variables that we know will exist, but might not yet.++    so_boundVarsCache :: IdSet,+    so_cachedScope :: Env+    }++emptySimplifyOpts = SimpOpts { so_noInlining  = False+                             , so_finalPhase  = False+                             , so_boundVars   = mempty+                             , so_forwardVars = mempty+                             , so_postLift    = False+                             , so_boundVarsCache = mempty+                             , so_cachedScope = mempty }++cacheSimpOpts opts = opts {+    so_boundVarsCache = idMapToIdSet (so_boundVars opts),+    so_cachedScope = cacheSubst (extendScope initScope mempty {+        envSubst = mapMaybeIdMap bb (so_boundVars opts), envRules = rules })+   } where+    bb Comb { combBody = e } | isFullyConst e = Just (Done e)+    bb _ = Nothing+    initScope = fmap (\ c -> isBoundTo opts (combHead c) noUseInfo (combBody c)) (so_boundVars opts)+    rules = mapMaybeIdMap f (so_boundVars opts)+    f Comb { combRules = rs } = if null rs then Nothing else Just $ arules rs++data Range = Done OutE | Susp InE Subst+    deriving(Show,Eq,Ord)+type Subst = IdMap Range++data Forced = ForceInline | ForceNoinline | NotForced+    deriving(Eq,Ord,Show)++data Binding+    = NotAmong [Name]+    | IsBoundTo {+        bindingOccurance :: !Occurance,+        bindingE :: OutE,+        bindingCheap :: !Bool,+        inlineForced :: !Forced,+        bindingAtomic :: !Bool+        }+    | NotKnown+    deriving(Ord,Eq,Show)++isBoundTo opt v o e = fixInline (so_finalPhase opt) v $ IsBoundTo {+    bindingOccurance = useOccurance o,+    bindingE = e,+    bindingCheap = isCheap e,+    inlineForced = case () of+      _ | useOccurance o == LoopBreaker -> ForceNoinline+        | otherwise -> NotForced,+    bindingAtomic = atomic+    } where+    atomic = isAtomic e++instance Monoid Forced where+    mempty = NotForced+    mappend NotForced x = x+    mappend x NotForced = x+    mappend _ ForceNoinline = ForceNoinline+    mappend ForceNoinline _ = ForceNoinline+    mappend ForceInline ForceInline = ForceInline++fixInline finalPhase v bt@IsBoundTo {} = bt {+    inlineForced = inlineForced bt `mappend` calcForced finalPhase v }+fixInline _ _ _ = error "SSimplify.fixInline: bad."++calcForced finalPhase v =+    let props = getProperties v in+        case (forceNoinline props,finalPhase,forceInline props) of+            (True,_,_) -> ForceNoinline+            (False,_,True) -> ForceInline+            (False,True,_) -> NotForced+            (False,False,False) -> NotForced++data Env = Env {+    envCachedSubst :: IdMap E,+    envSubst :: Subst,+    envRules :: IdMap ARules,+    envInScope :: IdMap Binding,+    envInScopeCache :: IdMap E+    }+    {-! derive: Monoid !-}++envSubst_u f r@Env{envSubst  = x} = r{envSubst = f x}+envSubst_s v =  envSubst_u  (const v)++susp:: E -> Subst -> Range+susp e sub =  Susp e sub++--insertSuspSubst :: TVr -> InE -> Env -> Env+--insertSuspSubst t e env = insertSuspSubst' (tvrIdent t) e env++--insertSuspSubst' :: Id -> InE -> Env -> Env+--insertSuspSubst' z _e env | isEmptyId z = env+--insertSuspSubst' t e env = cacheSubst env {+--    envSubst = minsert t (susp e (envSubst env)) (envSubst env) }++insertRange :: Id -> Range -> Env -> Env+insertRange z e env | isEmptyId z = env+insertRange t e env = cacheSubst env { envSubst = minsert t e (envSubst env) }++insertDoneSubst :: TVr -> OutE -> Env -> Env+insertDoneSubst t e env = insertDoneSubst' (tvrIdent t) e env++insertDoneSubst' :: Id -> OutE -> Env -> Env+insertDoneSubst' z _e env | isEmptyId z = env+insertDoneSubst' t e env = insertRange t (Done e) env++insertInScope :: Id -> Binding -> Env -> Env+insertInScope z _b env | isEmptyId z = env+insertInScope t b env = extendScope (msingleton t b) env++extendScope :: IdMap Binding -> Env -> Env+extendScope m env = cacheSubst env { envInScope = m `union` envInScope env+                                   , envInScopeCache = cachedM `union` envInScopeCache env }+    where cachedM = mapMaybeIdMap fromBinding m+          fromBinding (IsBoundTo {bindingE = e}) = Just e+          fromBinding _                          = Nothing++changeScope :: (Binding -> Binding) -> Env -> Env+changeScope fn env = cacheScope $ cacheSubst env { envInScope = fmap fn (envInScope env) }++cacheScope :: Env -> Env+cacheScope env = env { envInScopeCache = mapMaybeIdMap fromBinding (envInScope env) }+    where fromBinding (IsBoundTo {bindingE = e}) = Just e+          fromBinding _                          = Nothing++substLookup :: Id -> SM (Maybe Range)+substLookup id = SM $ ask >>= return . mlookup id . envSubst++substAddList ls env = cacheSubst env { envSubst = fromList ls `union` envSubst env }++applySubst :: Subst -> IdMap a -> IdMap OutE+applySubst s nn = applySubst' s where+    check n = n `member` s || n `member` nn+    applySubst' s = fmap g s+    g (Done e) = e+    g (Susp e s') = doSubst' False False (applySubst' s') check e++evalRange :: Range -> SM OutE+evalRange (Done e) = return e+evalRange (Susp e s) = localEnv (envSubst_s s)  $ dosub e++cacheSubst env = env { envCachedSubst = applySubst (envSubst env) (envInScope env) }++dosub :: InE -> SM OutE+dosub e = ask >>= \inb ->  coerceOpt return (doSubst' False False (envCachedSubst inb) (`member` envCachedSubst inb) e)++simplifyE :: SimplifyOpts -> InE -> (Stat,OutE)+simplifyE sopts e = (stat,e') where+    Identity ([Comb { combBody = e' }],stat) =  runStatT $ simplifyDs program sopts [bindComb (tvrSilly,e)]++programSSimplify :: SimplifyOpts -> Program -> Program+programSSimplify sopts prog = let+    Identity (dsIn,stats) = runStatT $ simplifyDs prog sopts (progCombinators prog)+    in (progCombinators_s dsIn prog) { progStats = progStats prog `mappend` stats }++programSSimplifyPStat :: SimplifyOpts -> Program -> IO Program+programSSimplifyPStat sopts prog = do+    setPrintStats True+    dsIn <- simplifyDs prog sopts (progCombinators prog)+    return (progCombinators_s dsIn prog)++type InE = E+type OutE = E+type InTVr = TVr+type OutTVr = TVr++data Cont =+    ApplyTo {+        contArg  :: Range,+        contNext :: Cont+        }+    | LazyContext TVr  -- the RHS of a let statement+    | StartContext+--    | ArgContext+    | Coerce Range Cont+{-    | Scrutinee {+        contExamined :: Bool  -- ^ whether the result is actually examined, or just bound to a variable+        }-}+    deriving(Show)++--isApplyTo ApplyTo {} = True+--isApplyTo _ = False++simplifyDs :: forall m . MonadStats m => Program -> SimplifyOpts -> [Comb] -> m [Comb]+simplifyDs prog sopts dsIn = ans where+    finalPhase = so_finalPhase sopts+    ans = do+        let ((dsOut,_),stats) = runSM (so_cachedScope sopts) doit+        mtickStat stats+        let lupRules t = concat [ combRules c | c <- dsIn, combIdent c == t]+        return [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- dsOut ]++    getType e = infertype (progDataTable prog) e+    doit = do+        smAddNamesIdSet (progUsedIds prog)+        smAddBoundNamesIdSet (progFreeIds prog)+        smAddBoundNamesIdSet (sfilter (`notElem` map combIdent dsIn) $ so_forwardVars sopts)+        smAddBoundNamesIdSet (so_boundVarsCache sopts)+        doDs (map combBind dsIn)+    makeRange b = do+        sub <- asks envSubst+        return $ susp b sub+    f :: Cont -> InE -> SM OutE+    --f cont e | trace (take 20 (show cont) ++ " - " ++ take 40 (show e)) False = undefined+--    f ArgContext e = dosub e+    f c (EAp a b) = do+        b' <- makeRange b+        f ApplyTo { contArg = b', contNext = c } a+    f (ApplyTo rng cont) (ELam t b) = do+        addBoundNames [tvrIdent t]+        mtick (toAtom $ "E.Simplify.f-beta-reduce/{" ++ pprint t)+        localEnv (insertRange (tvrIdent t) rng) $ f cont b+    f (ApplyTo rng cont) (EPi t b) = do+        addBoundNames [tvrIdent t]+        mtick (toAtom $ "E.Simplify.f-pi-reduce/{" ++ pprint t)+        localEnv (insertRange (tvrIdent t) rng) $ f cont b+    f cont (EVar v) = do+        z <- substLookup (tvrIdent v)+        case z of+            Just (Done e) -> done cont e+            Just (Susp e s) -> localEnv (envSubst_s s)  $ f cont e+            Nothing -> done cont (EVar v)+    f (Coerce t cont) (EError s _) = evalRange t >>= \t' -> done cont (EError s t')+    f (Coerce t cont) (ELit (LitInt n _)) = evalRange t >>= \t' -> done cont (ELit (LitInt n t'))+    f cont v | Just (e,t) <- from_unsafeCoerce v =+        makeRange t >>= \t' -> f (g t' cont) e where g t' (Coerce _ cont) = Coerce t' cont ; g t' cont = Coerce t' cont+    f cont ep@EPrim {} = do+        ep' <- performPrimOpt ep+        ep'' <- dosub ep'+        done cont ep''+    f cont (ELit lc@LitCons { litArgs = xs }) = do+        xs' <- mapM performPrimOpt xs+        dosub (ELit lc { litArgs = xs' }) >>= done cont+    f cont e@ELit {} = dosub e >>= done cont+    f cont (ELam v e)  = do+        addNames [tvrIdent v]+        v' <- nname v+        e' <- localEnv (insertDoneSubst v (EVar v') . insertInScope (tvrIdent v') NotKnown) $ f StartContext e+        done cont $ ELam v' e'+    f cont e@(EPi (TVr { tvrIdent = n }) _) = do+        addNames [n]+        e' <- dosub e+        done cont e'+    f cont (EError s t) = (EError s `fmap` dosub t) >>= done cont+    f cont ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do+        addNames (map tvrIdent $ caseBinds ec)+--        e' <- f (Scrutinee (not $ null as)) e+        e' <- f StartContext e+        ec' <- doCaseCont cont e' (eCaseType ec) b as d+        done StartContext ec'+    f cont ELetRec { eDefs = [], eBody = e } = f cont e+    f cont ELetRec { eDefs = ds@(_:_), eBody =  e } = do+        tickCont cont "let"+        (ds',inb') <- doDs ds+        e' <- localEnv (const inb') $ f cont e+        res <- case ds' of+            [(t,e)] | worthStricting e, Just (Demand.S _) <- Info.lookup (tvrInfo t), not (getProperty prop_CYCLIC t) -> do+                mtick $ "E.Simplify.strictness.let-to-case/{" ++ pprint t+                return $ eStrictLet t e e'+            [(t,ec@ECase { eCaseScrutinee = sc@(EPrim p _ _), eCaseAlts = [], eCaseDefault = Just def })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do+                mtick $ "E.Simplify.strictness.cheap-eagerness.def/{" ++ pprint t+                return $ caseUpdate ec { eCaseDefault = Just $ ELetRec [(t,def)] e', eCaseType = getType e' }+            [(t,ec@ECase { eCaseScrutinee = sc@(EPrim p _ _), eCaseAlts = [Alt c def], eCaseDefault = Nothing })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do+                mtick $ "E.Simplify.strictness.cheap-eagerness.con/{" ++ pprint t+                return $ caseUpdate ec { eCaseAlts = [Alt c (ELetRec [(t,def)] e')], eCaseType = getType e' }+            _ -> do+                let fn ds (ELetRec { eDefs = ds', eBody = e}) | not (hasRepeatUnder fst (ds ++ ds')) = fn (ds' ++ ds) e+                    fn ds e = f ds (Set.fromList $ fsts ds) [] False where+                        f ((t,ELetRec { eDefs = ds', eBody = e}):rs) us ds b | all (not . (`Set.member` us)) (fsts ds') = f ((t,e):rs) (Set.fromList (fsts ds') `Set.union` us) (ds':ds) True+                        f (te:rs) us ds b = f rs us ([te]:ds) b+                        f [] _ ds True = fn (concat ds) e+                        f [] _ ds False = (concat ds,e)+                let (ds'',e'') = fn ds' e'+                when (flint && hasRepeatUnder fst ds'') $ fail "hasRepeats!"+                mticks  (length ds'' - length ds') (toAtom $ "E.Simplify.let-coalesce")+                return $ eLetRec ds'' e''+        done StartContext res+    f cont e = trace ("Fall through: " ++ show (cont,e)) $ dosub e >>= done cont++    showName t | isJust (fromId t) || dump FD.EVerbose = tvrShowName (tVr t Unknown)+             | otherwise = "(epheremal)"++    -- Rename a if necessary. We always have to substitute all occurrences because we update the type.+    nname tvr@(TVr { tvrIdent = n, tvrType = t}) = do+        t' <- dosub t+        inb <- ask+        let t'' = substMap' (envInScopeCache inb) t'+        n' <- if n == emptyId then return emptyId else uniqueName n+        return $ tvr { tvrIdent = n', tvrType =  t'' }+    -- TODO - case simplification+    tickCont (ApplyTo _ cont) cs = mtick ("E.Simplify.application-push." ++ cs) >> tickCont cont cs+    tickCont (Coerce _ cont) cs = mtick ("E.Simplify.coerce-push." ++ cs) >> tickCont cont cs+    tickCont _ _ = return ()+    contType (ApplyTo z cont) t = contType cont t >>= \t' -> evalRange z >>= \z' -> return (eAp t' z')+    contType (Coerce t cont) _ = evalRange t+    contType _ t = return t+    doCaseCont :: Cont -> OutE -> InE -> InTVr -> [Alt InE] -> (Maybe InE) ->  SM OutE+    doCaseCont cont e t b as d = do+        inb <- ask+        let+            varval = do EVar v <- return e; mlookup (tvrIdent v) (envInScope inb)+            doCase ELetRec { eDefs = ds, eBody = e} t b as d = do+                mtick "E.Simplify.let-from-case"+                e' <- doCaseCont cont e t b as d+                done StartContext (substLet' ds e')++            doCase _ t b as d |  Just IsBoundTo { bindingE = ELit l } <- varval  = doConstCase cont l t  b as d+            doCase (EPi TVr { tvrType = x} y) t b as d = doConstCase cont litCons { litName = tc_Arrow, litArgs = [x,y], litType = eStar} t b as d+            doCase (ELit l) t b as d  = doConstCase cont l t b as d+            doCase (EVar v) t b as d | Just IsBoundTo { bindingE = e } <- varval , isBottom e = do+                mtick "E.Simplify.case-of-bottom'"+                t' <- makeRange t+                done (Coerce t' cont) (EVar v)+            doCase e t b as d | isBottom e = do+                mtick "E.Simplify.case-of-bottom"+                t' <- makeRange t+                done (Coerce t' cont) e++            doCase ic@ECase { eCaseScrutinee = e, eCaseBind =  b, eCaseAlts =  as, eCaseDefault =  d } t b' as' d'+                | length (filter (not . isBottom) (caseBodies ic)) <= 1 ||+                  all whnfOrBot (caseBodies ic)  ||+                  all whnfOrBot (caseBodies emptyCase { eCaseAlts = as', eCaseDefault = d'} )  = do+                mtick (toAtom "E.Simplify.case-of-case")+                let f (Alt l e) = do+                        e' <- localEnv (extendScope (fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ]))+                                $ doCaseCont StartContext e t b' as' d'+                        return (Alt l e')+                    --g e >>= return . Alt l+                    g x = localEnv (insertInScope (tvrIdent b) NotKnown) $ doCaseCont StartContext x t b' as' d'+                as'' <- mapM f as+                d'' <- T.mapM g d+                t' <- dosub t+                done cont $ caseUpdate ECase {+                    eCaseAllFV = error "eCaseAllFV",+                    eCaseScrutinee = e,+                    eCaseType = t',+                    eCaseBind = b,+                    eCaseAlts = as'',+                    eCaseDefault = d''} -- XXX     -- we duplicate code so continue for next renaming pass before going further.+            doCase ic@ECase { eCaseType = it, eCaseScrutinee = e, eCaseBind =  b, eCaseAlts =  as, eCaseDefault =  d } t b' as' d' | not (isUnboxedTuple it) = do+                mtick (toAtom "E.Simplify.case-of-case-join")+                n1 <- newName+                n2 <- newName+                let cvar = setProperty prop_ONESHOT $ tVr n1 it+                rcc <- doCaseCont StartContext (EVar cvar) t b' as' d'+                let fbody = ELam cvar rcc+                    zvar = setProperties [prop_JOINPOINT,prop_ONESHOT] $ tVr n2 (EPi tvr { tvrType = it } (getType rcc))+                nic <- flip caseBodiesMapM ic $ \body -> return $ eLet cvar body (eAp (EVar zvar) (EVar cvar))+                done cont $ eLet zvar fbody nic { eCaseType = getType rcc }+            doCase e t b as@(Alt LitCons { litName = n } _:_) (Just d) | Just nsib <- numberSiblings (progDataTable prog) n, nsib <= length as = do+                mtick "E.Simplify.case-no-default"+                doCase e t b as Nothing+            doCase e t b (a@(Alt LitCons { litName = n } _):_) (Just d) | Just _ <- fromUnboxedNameTuple n = do+                mtick "E.Simplify.case-unboxed-no-default"+                doCase e t b [a] Nothing+{-+  Remove the default case if possible.+  case lst of [] -> True; _ -> False+  ==>+  case lst of [] -> True; (:) _ _ -> False+-}+            doCase e t b as (Just d) | te /= tWorld__, (ELit LitCons { litName = cn }) <- followAliases dt te+                                     , Just Constructor { conChildren = DataNormal cs } <- getConstructor cn dt+                                     , length as == length cs - 1 || (False && length as < length cs && isAtomic d)  = do+                let ns = [ n | Alt ~LitCons { litName = n } _ <- as ]+                    ls = filter (`notElem` ns) cs+                    ff n = do+                        con <- getConstructor n dt+                        let g t = do+                                n <- newName+                                return $ tVr n t+                        ts <- mapM g (slotTypes (progDataTable prog) n te)+                        let wtd = ELit $ updateLit (progDataTable prog) litCons { litName = n, litArgs = map EVar ts, litType = te }+                        return $ Alt (updateLit (progDataTable prog) litCons { litName = n, litArgs = ts, litType = te }) (eLet b wtd d)+                mtick $ "E.Simplify.case-improve-default.{" ++ show (sort ls) ++ "}"+                ls' <- mapM ff ls+                --ec <- dosub $ caseUpdate emptyCase { eCaseScrutinee = e, eCaseType = t, eCaseBind = b, eCaseAlts = as ++ ls' }+                --localEnv (envSubst_s mempty) $ f StartContext (caseUpdate ec { eCaseScrutinee = e })+                doCase e t b (as ++ ls') Nothing+                where+                te = getType b+                dt = (progDataTable prog)+            doCase e _ b [] (Just d) | not (isLifted e || isUnboxed (getType e)) = do+                mtick "E.Simplify.case-unlifted"+                b' <- nname b+                d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e))) $ f cont d+                done StartContext $ eLet b' e d'+            doCase e@ELam {} _ b [] (Just d)  = do+                mtick "E.Simplify.case-lambda"+                b' <- nname b+                d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e))) $ f cont d+                done StartContext $ eLet b' e d'+            -- atomic unboxed values may be substituted or discarded without replicating work or affecting program semantics.+            doCase e _ b [] (Just d) | isUnboxed (getType e), isAtomic e = do+                mtick "E.Simplify.case-atomic-unboxed"+                localEnv (insertDoneSubst b e) $ f cont d+            doCase e _ TVr { tvrIdent = z } [] (Just d) | isEmptyId z, isOmittable inb e = do+                mtick "E.Simplify.case-omittable"+                f cont d+            doCase (EVar v) _ b [] (Just d) | Just (NotAmong _) <-  varval  = do+                mtick $ "E.Simplify.case-evaled/{" ++ pprint v+                localEnv (insertDoneSubst b (EVar v)) $ f cont d+            doCase e _ b [] (Just (EVar v')) | b == v' = do+                mtick $ "E.Simplify.case-trailing/{" ++ pprint b+                done cont e+            doCase scrut _ v [] (Just sc@ECase { eCaseScrutinee = EVar v'} ) | v == v', tvrIdent v `notMember` (freeVars (caseBodies sc) :: IdSet)  = do+                mtick "E.Simplify.case-default-case"+                doCase scrut (eCaseType sc) (eCaseBind sc) (eCaseAlts sc) (eCaseDefault sc)+            doCase e t b as d = do+                tickCont cont "case"+                b' <- nname b+                (ids,b') <- case (e,tvrIdent b') of+                    (EVar v,z) | isEmptyId z -> do+                        nn <- newName+                        b' <- return b' { tvrIdent = nn }+                        return $ (insertInScope (tvrIdent v) (isBoundTo sopts v noUseInfo (EVar b')),b')+                    (EVar v,_) -> return $ (insertDoneSubst b (EVar b') . insertInScope (tvrIdent v) (isBoundTo sopts v noUseInfo (EVar b')),b')+                    _ -> return $ (insertDoneSubst b (EVar b'),b')+                inb <- ask+                let dd e' = localEnv (const $ ids $ extendScope newinb inb) $ f cont e' where+                        na = NotAmong [ n | Alt LitCons { litName = n } _ <- as]+                        newinb = fromList [ (n,na) | EVar (TVr { tvrIdent = n }) <- [EVar b']]+                    da (Alt (LitInt n t) ae) = do+                        t' <- dosub t+                        let p' = LitInt n t'+                        e' <- localEnv (ids . mins e (patToLitEE p')) $ f cont ae+                        return $ Alt p' e'+                    da (Alt lc@LitCons { litName = n, litArgs = ns, litType = t } ae) = do+                        t' <- dosub t+                        ns' <- mapM nname ns+                        let p' = lc { litArgs = ns', litType = t' }+                            nsub =  [ (n,Done (EVar t))  | TVr { tvrIdent = n } <- ns | t <- ns' ]+                            ninb = fromList [ (n,NotKnown)  | TVr { tvrIdent = n } <- ns' ]+                        e' <- localEnv (const $ ids $ substAddList nsub (extendScope ninb $ mins e (patToLitEE p') inb)) $ f cont ae+                        return $ Alt p' e'+                    mins _ e | emptyId `notMember` (freeVars e :: IdSet) = insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e)+                    mins _ _ = id++                d' <- T.mapM dd d+                as' <- mapM da as+                t' <- dosub t+                t' <- contType cont t'+                done StartContext $ caseUpdate ECase {+                    eCaseAllFV = error "eCaseAllFV",+                    eCaseScrutinee = e,+                    eCaseType = t',+                    eCaseBind =  b',+                    eCaseAlts = as',+                    eCaseDefault = d'}+        doCase e t b as d++    isOmittable _ ELit {} = True+    isOmittable _ EPi {} = True+    isOmittable _ ELam {} = True+    isOmittable _ (EPrim p _ _) = primIsConstant p+    isOmittable inb (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of+        Just IsBoundTo { bindingE = e } | not (isEVar e) -> isOmittable inb e+        Just (NotAmong _) -> True+        _ -> False+    isOmittable _ _ = False++    doConstCase :: Cont -> {- Out -} Lit E E -> InE -> InTVr -> [Alt E] -> Maybe InE -> SM OutE+    doConstCase cont l t b as d = do+        t' <- dosub t+        mr <- match l as (b,d)+        inb <- ask+        case mr of+            Just (bs,e) -> do+                let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= emptyId]+                binds <- mapM (\ (v,e) -> nname v >>= return . (,,) e v) bs'+                e' <- localEnv (substAddList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] . extendScope (fromList [ (n,isBoundTo sopts t noUseInfo e) | (e,_,t@TVr { tvrIdent = n }) <- binds])) $ f StartContext e+                done cont $ eLetRec [ (v,e) | (e,_,v) <- binds ] e'+            Nothing -> do+                done cont $ EError ("match falls off bottom: " ++ pprint l) t'++    match m@LitCons { litName = c, litArgs = xs } ((Alt LitCons { litName = c', litArgs = bs } e):rs) d@(b,_) | c == c' = do+        mtick (toAtom $ "E.Simplify.known-case." ++ show c )+        return $ Just ((b,ELit m):(zip bs xs),e)+         | otherwise = match m rs d+    match m@(LitInt x _) ((Alt (LitInt y _) e):rs) d@(b,_) | x == y = do+        mtick (toAtom $ "E.Simplify.known-case." ++ show x)+        return $ Just ([(b,ELit m)],e)+         | otherwise = match m rs d+    match m@LitCons { litName = c } [] (_,Just e) | Just _ <- fromUnboxedNameTuple c  = do+        mtick (toAtom $ "E.Simplify.known-case._#" ++ show c )+        return (Just ([],e))+    match l [] (b,Just e) = do+        mtick (toAtom "E.Simplify.known-case._")+        return $ Just ([(b,ELit l)],e)+    match m [] (_,Nothing) = do+        mtick (toAtom "E.Simplify.known-case.unmatch")+        return Nothing+    match m as d = error $ "Odd Match: " ++ show ((m,getType m),as,d)++    applyRule :: OutTVr -> [OutE] -> SM (Maybe (OutE,[OutE]))+    applyRule v xs  = do+        inb <- ask+        z <- builtinRule v xs+        let lup x = case mlookup x (envInScope inb) of+                Just IsBoundTo { bindingE = e } -> Just e+                _ -> Nothing+        case z of+            Nothing | fopts FO.Rules -> applyRules lup (findWithDefault mempty (tvrIdent v) $ envRules inb) xs+            x -> return x+    done cont e = z cont [] where+        z (ApplyTo r cont') rs = evalRange r >>= \a -> z cont' (a:rs)+        z (Coerce t cont) rs = do+            t' <- evalRange t+            z <- hFunc e (reverse rs)+            done cont (prim_unsafeCoerce z t')+        z _ rs = hFunc e (reverse rs)+    hFunc :: OutE -> [OutE] -> SM OutE+    hFunc (EVar v) xs' = do+        inb <- ask+        z <- applyRule v xs'+        let txs = map tx xs' where+                tx (ELit l) = knowLit l+                tx EPi {} = KnowSomething+                tx (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of+                    Just (NotAmong xs) -> KnowNotOneOf xs+                    Just IsBoundTo { bindingE = ELit l } -> knowLit l+                    Just IsBoundTo {} -> KnowSomething+                    _ -> KnowNothing+                tx _ = KnowNothing+                knowLit LitCons { litName = c } = KnowIsCon c+                knowLit (LitInt n _) = KnowIsNum n+        case z of+            (Just (x,xs)) -> didInline x xs+            _ -> case mlookup (tvrIdent v) (envInScope inb) of+                Just IsBoundTo { inlineForced = ForceNoinline } -> appVar v xs'+                Just IsBoundTo { bindingOccurance = Once } -> error "IsBoundTo: Once"+                Just IsBoundTo { bindingE = e, bindingAtomic = True }  -> do+                    mtick  (toAtom $ "E.Simplify.inline.atomic/{" ++ tvrShowName v  ++ "}")+                    didInline e xs'+                Just IsBoundTo { bindingE = e, inlineForced = ForceInline } | someBenefit v e txs -> do+                    mtick  (toAtom $ "E.Simplify.inline.Forced/{" ++ tvrShowName v  ++ "}")+                    didInline e xs'+--                Just ibt@IsBoundTo { bindingE = e } | False && someBenefit v e txs && getProperty prop_WRAPPER v -> do+--                    mtick  (toAtom $ "E.Simplify.inline.Wrapper/{" ++ tvrShowName v  ++ "}")+--                    trace (show (v,e,ibt,tvrInfo v)) didInline e xs'+                Just IsBoundTo { bindingOccurance = OnceInLam, bindingE = e, bindingCheap = True } | someBenefit v e txs -> do+                    mtick  (toAtom $ "E.Simplify.inline.OnceInLam/{" ++ showName (tvrIdent v)  ++ "}")+                    didInline e xs'+                Just IsBoundTo { bindingOccurance = ManyBranch, bindingE = e } | multiInline v e txs -> do+                    mtick  (toAtom $ "E.Simplify.inline.ManyBranch/{" ++ showName (tvrIdent v)  ++ "}")+                    didInline e xs'+                Just IsBoundTo { bindingOccurance = Many, bindingE = e, bindingCheap = True } | multiInline v e txs -> do+                    mtick  (toAtom $ "E.Simplify.inline.Many/{" ++ showName (tvrIdent v)  ++ "}")+                    didInline e xs'+                Just _ -> appVar v xs'+                Nothing  -> appVar v xs'+                -- Nothing | tvrIdent v `Set.member` exports -> app (EVar v,xs')+                -- Nothing -> error $ "Var not in scope: " ++ show v+    hFunc e xs' = do app (e,xs')+    didInline ::OutE -> [OutE] -> SM OutE+    didInline z zs = return (foldl EAp z zs)+    --didInline z zs = do+    --    used <- smUsedNames+    --    let (ne,nn) = runRename used (foldl EAp z zs)+    --    smAddNamesIdSet nn+    --    return ne+    appVar v xs | so_postLift sopts = app (EVar v,xs)+    appVar v xs = do+        me <- etaExpandAp (progDataTable prog) v xs+        case me of+            Just e -> return e+            Nothing -> app (EVar v,xs)++    app (e,[]) = return e+    app (e,xs) = app' e xs++    app' (ELit lc@LitCons { litName = n, litArgs = xs, litType = EPi ta tt }) (a:as)  = do+        mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" )+        app' (ELit lc { litArgs = xs ++ [a], litType = subst ta a tt }) as+    app' (ELit LitCons { litName = n, litArgs = es, litAliasFor = Just af }) bs@(_:_) = do+        mtick (toAtom $ "E.Simplify.newtype-reduce.{" ++ show n ++ "}" )+        app' (foldl eAp af (es ++ bs)) []+    app' (EError s t) xs = do+        mticks (length xs) (toAtom "E.Simplify.error-application")+        return $ EError s (foldl eAp t xs)+    app' e as = do+        return $ foldl EAp e as+    doDs ds = do+        addNames $ map (tvrIdent . fst) ds+        let z :: (InTVr,InE) -> SM (Id,UseInfo,OutTVr,InE)+            z (t,EVar t') | t == t' = do    -- look for simple loops and replace them with errors.+                t'' <- nname t+                mtick $ "E.Simplify.<<loop>>.{" ++ showName (tvrIdent t) ++ "}"+                return (tvrIdent t,noUseInfo,t'',EError "<<loop>>" (getType t))+            z (t,e) = do+                t' <- nname t+                case Info.lookup (tvrInfo t) of+                    _ | forceNoinline t -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e)+                      | so_postLift sopts && (isELam e || isECase e) -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e)+                    Just ui@UseInfo { useOccurance = Once } -> return (tvrIdent t,ui,error $ "Once: " ++ show t,e)+                    Just n -> return (tvrIdent t,n,t',e)+                    -- We don't want to inline things we don't have occurance info for because they might lead to an infinite loop. hopefully the next pass will fix it.+                    Nothing -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e)+                    -- Nothing -> error $ "No Occurance info for " ++ show t+            w :: [(Id,UseInfo,OutTVr,InE)] -> [(OutTVr,OutE)] -> SM ([(OutTVr,OutE)],Env)+            w ((t,UseInfo { useOccurance = Once },t',e):rs) ds = do+                mtick $ "E.Simplify.inline.Once/{" ++ showName t ++ "}"+                w rs ds -- (minsert t (Susp e sub) sub) inb ds+            w ((t,n,t',e):rs) ds = do+                let inb = case isForced of+                        ForceInline -> cacheSubst . changeScope nogrowth+                        _ -> id+                    isForced = calcForced finalPhase t'+                    nogrowth IsBoundTo { bindingAtomic = False } = NotKnown+                    nogrowth x = x+                e' <- localEnv inb $ f (LazyContext t') e+                let ibt = isBoundTo sopts t' n e'+                case (bindingAtomic ibt,inlineForced ibt) of+                    (True,f) | f /= ForceNoinline -> do+                        --when (n /= Unused) $ mtick $ "E.Simplify.inline.Atomic.{" ++ showName t ++ "}"+                        localEnv (insertDoneSubst' t e' . insertInScope (tvrIdent t') ibt) $ w rs  ((t',e'):ds)+                    _ -> localEnv (insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds)+            w [] ds = ask >>= \inb -> return (ds,inb)+        s' <- mapM z ds+        inb <- ask+        let sub'' = fromList [ (t,susp e sub'') | (t, UseInfo { useOccurance = Once },_,e) <- s'] `union` fromList [ (t,Done (EVar t'))  | (t,n,t',_) <- s', useOccurance n /= Once] `union` envSubst inb+        (ds',inb') <- localEnv (envSubst_s sub'' . extendScope (fromList [ (tvrIdent t',NotKnown) | (_,n,t',_) <- s', useOccurance n /= Once])) $ w s' []+        let minArgs t = case Info.lookup (tvrInfo t) of+                Just (UseInfo { minimumArgs = min }) -> min+                Nothing -> 0++        ds' <- if so_postLift sopts then return ds' else  sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds']+        return (ds',inb')++data KnowSomething = KnowNothing | KnowNotOneOf [Name] | KnowIsCon Name | KnowIsNum Number | KnowSomething+    deriving(Eq)++someBenefit _ e _ | isAtomic e = True+someBenefit _ ELit {} _ = True+someBenefit _ EPi {} _ = True+someBenefit _ EPrim {} _ = True+someBenefit v ELetRec { eDefs = ds, eBody = e } xs | someBenefit v e xs = True+--someBenefit _v ECase {} (_:_) = True+someBenefit _ e xs | f e xs = True where+    f (ELam _ e) (_:xs) = f e xs+    f ELam {} [] = any (/= KnowNothing) xs+    f _ _ = not (null xs)+someBenefit v e xs = any (/= KnowNothing) xs++exprSize ::+    Int            -- ^ maximum size before bailing out+    -> E           -- ^ expression+    -> Int         -- ^ discount for case of something known+    -> [(Id,KnowSomething)]        -- ^ things that are known+    -> Maybe Int+exprSize max e discount known = f max e >>= \n -> return (max - n) where+    f n _ | n <= 0 = fail "exprSize: expression too big"+    f n EVar {} = return $! n - 1+    f n (EAp x@(EVar v) y) | Just _ <- lookup (tvrIdent v) known = do+        v <- f (n + discount) x+        f v x+    f n (EAp x y) = do+        v <- f n x+        f v x+    f n (ELam t x) = f (n - 1) x+    f n EPi {} = return $! n - 1+    f n ELit {} = return $! n - 1+    f n ESort {} = return $! n - 1+    f n EPrim {} = return $! n - 1+    f n EError {} = return $! n - 1+    f n ec@ECase { eCaseScrutinee = EVar tv } | Just l <- lookup (tvrIdent tv) known = do+        n <- f (n + discount) (EVar tv)+        let g n []  | Just d <- eCaseDefault ec = f n d+                    | otherwise  = return n+            g n (Alt LitCons { litName = c' } e:rs) | KnowIsCon c <- l = if c == c' then f n e else g n rs+            g n (Alt (LitInt c' _) e:rs) | KnowIsNum c <- l = if c == c' then f n e else g n rs+            g n (Alt LitCons { litName = c } e:rs) | KnowNotOneOf na <- l = if c `elem` na then g n rs else f n e >>= \n' -> g n' rs+            g n (Alt _ e:rs) = f n e >>= \n' -> g n' rs+        g n (eCaseAlts ec)+    f n ec@ECase {} = do+        n <- f n (eCaseScrutinee ec)+        foldM f n (caseBodies ec)+    f n ELetRec {eDefs = ds, eBody = e } = do+        n <- foldM f n (snds ds)+        f n e+    f _ Unknown = error "SSimplify.exprSize: bad."++noSizeIncrease e xs = f e xs where+    currentSize = 1 + length xs+    f (ELam t e) (x:xs) = f e xs+    f ELam {} [] = False -- ^ abort if we will create a lambda+    f e [] = isJust $ exprSize currentSize  e 3 []+    f e xs = isJust $ exprSize (currentSize - length xs) e 3 []++--multiInline _ e xs | isSmall (f e xs) = True  where -- should be noSizeIncrease+--    f e [] = e+--    f (ELam _ e) (_:xs) = f e xs+--    f e xs = foldl EAp e xs+--+--++scrutineeDiscount = 4+extraArgDiscount = 1+knowSomethingDiscount = 2++multiInline _ e xs | noSizeIncrease e xs = True+multiInline v e xs | not (someBenefit v e xs) = False+multiInline v e xs = f e xs [] where+    currentSize = 1 + length xs+    f (ELam t e) (KnowNothing:xs) rs = f e xs rs+    f (ELam t e) (x:xs) rs = f e xs ((tvrIdent t,x):rs)+    f e xs rs = isJust $ exprSize (knowSomethingDiscount*(length rs) + discount + currentSize + (if null xs then 0 else extraArgDiscount)) e scrutineeDiscount rs where+           discount = if safeToDup e then 4 else 0++worthStricting EError {} = True+worthStricting ELit {} = False+worthStricting ELam {} = False+worthStricting x = sortTermLike x++coerceOpt :: MonadStats m =>  (E -> m E) -> E -> m E+coerceOpt fn e = do+    let (n,e',p) = unsafeCoerceOpt e+    n `seq` stat_unsafeCoerce `seq` mticks n stat_unsafeCoerce+    e'' <- fn e'+    return (p e'')++stat_unsafeCoerce = toAtom "E.Simplify.unsafeCoerce"++-----------------------+-- simplification Monad+-----------------------++data SmState = SmState {+    idsSeed :: {-# UNPACK #-} !Int,+    idsUsed :: !IdSet,+    idsBound :: !IdSet+    }++smState = SmState { idsSeed = 1, idsUsed = mempty, idsBound = mempty }++newtype SM a = SM (RWS Env Stats.Stat SmState a)+    deriving(Monad,Functor,MonadReader Env, MonadState SmState)++localEnv f (SM action) = SM $ local (cacheSubst . f) action++runSM :: Env -> SM a -> (a,Stat)+runSM env (SM x) = (r,s) where+    (r,_,s) = runRWS x (cacheSubst env) smState++instance MonadStats SM where+   mticks' n k = SM $ tell (Stats.singleStat n k) >> return ()+   mtickStat = error "MonadStats.mtickStat: not impl."++modifyIds fn = SM $ modify f where+    f s@SmState { idsUsed = used, idsBound = bound } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound' }+getIds = SM $ liftM f get where+    f s@SmState { idsUsed = used, idsBound = bound } = (used,bound)+putIds x = SM $ modify (f x) where+    f (used,bound) = \s -> s { idsUsed = used, idsBound = bound }++instance NameMonad Id SM where+    addNames ns = do+        modifyIds (\ (used,bound) -> -- trace ("AddNames: " ++ show (size used,size bound)) $+                   (fromList ns `union` used, bound) )+    addBoundNames ns = do+        let nset = fromList ns+        modifyIds (\ (used,bound) -> --trace ("AddBoundNames: " ++ show (size used, size bound))+                   (nset `union` used, nset `union` bound) )+    uniqueName n = do+        (used,bound) <- getIds+        if n `member` bound then newName else putIds (insert n used,insert n bound) >> return n+    newNameFrom vs = do+        (used,bound) <- getIds+        let f (x:xs)+                | x `member` used = f xs+                | otherwise = x+            f [] = error "newNameFrom: finite list!"+            nn = f vs+        putIds (insert nn used, insert nn bound)+        return nn+    newName  = do+        seed <- gets idsSeed+        modify (\e -> e { idsSeed = seed + 1 })+--        (used,bound) <- getIds+        newNameFrom $ candidateIds seed -- (size used + 10000*size bound)++--smUsedNames = SM $ gets idsUsed+--smBoundNames = SM $ gets idsBound++smAddNamesIdSet nset = --trace ("addNamesIdSet: "++ show (size nset)) $+   do modifyIds (\ (used,bound) -> (nset `union` used, bound) )+smAddBoundNamesIdSet nset = --trace ("addBoundNamesIdSet: "++show (size nset)) $+   do modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) )++--smAddBoundNamesIdMap = smAddNamesIdSet . idMapToIdSet+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Monoid Env where+    mempty = Env mempty mempty mempty mempty mempty+    mappend (Env aa ab ac ad ae) (Env aa' ab' ac' ad' ae') = Env (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')++--  Imported from other files :-
+ drift_processed/E/ToHs.hs view
@@ -0,0 +1,493 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/ToHs.hs" #-}+module E.ToHs(compileToHs) where++import Char+import Control.Monad+import Control.Monad.Identity+import Control.Monad.RWS+import Control.Monad.Trans+import Control.Monad.Writer+import Data.Monoid+import System.IO+import Text.PrettyPrint.HughesPJ(render,($$),nest,Doc())+import qualified Data.Set as Set+import qualified Data.Traversable as T+import qualified System++import C.Arch+import C.Prims+import DataConstructors+import Doc.DocLike+import Doc.PPrint+import E.E+import E.FreeVars+import E.Program+import E.Subst+import E.Traverse+import E.Values+import Name.Id+import Name.Name+import Name.Names+import Name.Prim+import Name.VConsts+import Numeric+import Options+import PackedString+import RawFiles(viaghc_hs)+import Support.CanType+import Support.FreeVars+import Util.Gen+import Util.SetLike+import qualified FlagDump as FD++progress str = wdump FD.Progress $  (putErrLn str) >> hFlush stderr++{-# NOINLINE compileToHs #-}+compileToHs :: Program -> IO ()+compileToHs prog = do+    (v,_,Coll { collNames = ns, collPrims = prims }) <- runRWST (fromTM $ transE (programE prog)) emptyEnvironment 1++    let rv = render (text "theRealMain = " <> v)+    let data_decls = render (transDataTable (progDataTable prog) ns) ++ "\n"+    let foreign_decls = render (transForeign $ Set.toList prims) ++ "\n"+    let fn = optOutName options+    let cf = (fn ++ "_code.hs")+    progress ("Writing " ++ show cf)+    name <- System.getProgName+    args <- getArguments+    let argstring = simpleQuote (name:args)+        comm = shellQuote $ ["ghc", "-O", cf, "-o", fn ]+    writeFile cf $ unlines ["-- " ++ argstring,"-- " ++ comm,"",viaghc_hs,render restate,data_decls,rv,"",foreign_decls]+    progress ("Running: " ++ comm)+    r <- System.system comm+    when (r /= System.ExitSuccess) $ fail "Hs code did not compile."+    return ()++cTypeInfoT (ELit LitCons { litAliasFor = Just af }) = cTypeInfoT af+cTypeInfoT (ELit LitCons { litName = n }) | (RawType,t) <- fromName n = cTypeInfo t++cTypeInfo "wchar_t" = ("Char#","C#","Char")+cTypeInfo "HsChar" = ("Char#","C#","Char")+cTypeInfo "HsPtr" =  ("Addr#","Ptr","(Ptr ())")+cTypeInfo "HsFunPtr" =  ("Addr#","Ptr","(Ptr ())")+cTypeInfo n = (if primTypeIsSigned pi then "Int#" else "Word#",v,i) where+        (v,i) = if primTypeIsSigned pi then ('I':nn ++ "#","Int" ++ nn) else ('W':nn ++ "#","Word" ++ nn)+        nn = show $ primTypeSizeOf pi * 8+        Just pi = primitiveInfo n++showCType n = fst3 $ cTypeInfo n++restate = vcat $ map f restated where+    f (n,nn,v) = g (nameType n) <> text v <+> text "=" <+> showTCName nn n+    g DataConstructor = empty+    g TypeConstructor = text "type "+    restated = [+        (dc_Cons,0,"jhc_Cons"),+        (dc_EmptyList,0,"jhc_EmptyList"),+        (tc_List,1,"ListTCon")+        ]++transForeign ps = vcat (map f ps) where+    f (AddrOf s) = text $ "foreign import ccall \"&" ++ unpackPS s ++ "\" addr_" ++ mangleIdent (unpackPS s) ++ " :: Ptr ()"+    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = "void" } = ans <$> ans' where+        ans  = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ intercalate " -> " (map (snd . snd) vals ++ ["IO ()"])+        ans' = text $ cfuncname furc <+> "w" <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> intercalate " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of IO f -> case f w of (# w, _ #) -> w"+        vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]+    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt' } = ans <$> ans' where+        ans  = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ intercalate " -> " (map (snd . snd) vals ++ ["IO " ++ rt])+        ans' = text $ cfuncname furc <+> "w" <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> intercalate " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of IO f -> case f w of (# w, " ++ rc ++ " r #) -> (# w, r #)"+        vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]+        (rc,rt) = ioInfo rt'+    f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt' } = ans <$> ans' where+        ans  = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ intercalate " -> " (map (snd . snd) vals ++ [rt])+        ans' = text $ cfuncname furc <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> intercalate " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of " ++ rc ++ " r -> r"+        vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]+        (rc,rt) = ioInfo rt'+--    f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt } = ans where+--       ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ intercalate " -> " (map showCType (as ++ [rt]))+--    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt } = ans where+--        ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ intercalate " -> " ("World__":(map showCType as ++ ["(# World__, " ++ showCType rt ++ " #)"]))+    f n = text "{- Foreign.Error " <+> tshow n <+> text "-}"+    ioInfo n = (x,y) where+        (_,x,y) = cTypeInfo n++transDataTable dataTable ns = vcat (theType:map g (lefts wtd)) where+    wtd =  Set.toList (mconcatMap f (Set.toList ns))+    f (n,_,_) | n `elem` builtIns = Set.empty+    f (n,_,_) | Just _ <- fromUnboxedNameTuple n = Set.empty+    f (n,_,_) | Just _ <- fromTupname n = Set.empty+    f w@(n,nn,tl) = case (nameType n,tl) of+        (DataConstructor,False) -> Set.fromList $ do+            c <- getConstructor n dataTable+            return (Left $ conInhabits c)+        (TypeConstructor,True) -> Set.singleton (Left n)+        (TypeConstructor,False) -> Set.singleton (Right (n,nn))+        (RawType,_) -> Set.empty+        (nt,_) -> error (show (w,nt))+    theType = text "data Type = Char | Int" <+> case rights wtd of+        [] -> empty+        as -> text "|" <+> hcat (punctuate (text " | ") (map tt as))+    tt (n,nn) = hsep (showTCName nn n:replicate nn (text "Type"))++    g n = ans where+        ans = text "data" <+> hsep (showTCName (length $ conSlots con) n:[ text ('x':show i) | _ <- conSlots con | i <- [2::Int,4 ..] ]) <+> dchildren+        Just con = getConstructor n dataTable+        childs = conChildren con+        dchildren | DataNormal [] <- childs = empty+                  | DataNormal childs <- childs  =  text "=" <+> hcat (punctuate (text " | ") (map dc childs))+                  | otherwise = empty+    dc cn = ans where+        ans = hsep (showCName cn: map showSlot (conSlots con))+        Just con = getConstructor cn dataTable+    showSlot (EVar v) = pprint v+    showSlot (ELit LitCons { litArgs = es, litAliasFor = Just af }) = showSlot (foldl eAp af es)+    showSlot (EPi TVr { tvrType = a } b) = parens $ showSlot a <+> text "->" <+> showSlot b+    showSlot (ELit (LitCons { litName = c, litArgs = as })) = showCon c (map showSlot as)+    --builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,rt_int,rt_HsChar,tc_World__,tc_Array__,tc_MutArray__,tc_Ref__,rt_HsPtr]+    builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,tc_World__,tc_Array__,tc_MutArray__,tc_Ref__]++data Environment = Env {+    envParen  :: Bool,+    envType   :: Bool,+    envCoerce :: IdSet+    }++emptyEnvironment = Env {+    envParen  = False,+    envType   = False,+    envCoerce = mempty+    }++data Collect = Coll { collNames :: Set.Set (Name,Int,Bool), collPrims :: Set.Set Prim }+    {-! derive: Monoid !-}++newtype TM a = TM { fromTM :: RWST Environment Collect Int IO a }+    deriving(MonadState Int,MonadReader Environment,MonadWriter Collect,Monad,Functor,MonadIO)++mparen xs = do+    Env { envParen = p } <- ask+    x <- local (\e -> e { envParen = True }) xs+    if p then return $ parens x else return x++nparen xs = do local (\e -> e { envParen = True }) xs++noParens x = local (\e -> e { envParen = False }) x++showCon c ts | Just 0 <- fromUnboxedNameTuple c, nameType c == TypeConstructor = text "Nothing"+showCon c ts | Just 0 <- fromUnboxedNameTuple c, nameType c == DataConstructor = text "theNothing"+showCon c ts | Just _ <- fromUnboxedNameTuple c = text "(# " <> hsep (punctuate comma ts) <> text " #)"+showCon c ts | Just _ <- fromTupname c = text "(" <> hsep (punctuate comma ts) <> text ")"+showCon c [] | c == tc_World__ = text "World__"+showCon c [a] | c == tc_Array__ = parens $ text "Array__" <+> a+showCon c [a] | c == tc_MutArray__ = parens $ text "MutArray__" <+> a+showCon c [a] | c == tc_Ref__ = parens $ text "Ref__" <+> a+showCon c [] | (RawType,v) <- fromName c = text $ showCType v+showCon c [] | c == tc_Int = text "Int"+showCon c [] | c == tc_Char = text "Char"+showCon c [] = showTCName 0 c+showCon c ts = parens $ hsep (showTCName (length ts) c:ts)++showTCName n c | nameType c == TypeConstructor = showCName c <> text "_" <> tshow n+showTCName _ c = showCName c++showCName c  | c == dc_Char = text "C#"+showCName c  | c == dc_Int = text "I#"+showCName c = text $ case nameType c of+    DataConstructor -> 'D':mangleIdent (show c)+    TypeConstructor -> 'T':mangleIdent (show c)+    n -> 'U':mangleIdent (show n ++ "_" ++ show c)++transType :: E -> TM Doc+transType e | typeLike e = return $ text "Type"+transType (EPi TVr {tvrType = a } b) = local (\e -> e { envType = True }) $ mparen $ do+    a <- transType a+    b <- transType b+    return $ a <+> text "->" <+> b+transType (ELit LitCons { litArgs = es, litAliasFor = Just af }) = transType (foldl eAp af es)+transType (ELit LitCons { litName = c, litArgs =  ts }) = nparen $ do+    Env { envType = inType } <- ask+    tell mempty { collNames = Set.singleton (c,length ts,inType) }+    ts <- mapM transType ts+    return $ showCon c ts+transType e = return $ text "{- ERROR " <> tshow e <> text " -} Type"++typeLike (ESort EStar) = True+typeLike (EPi TVr { tvrType = a } b) = typeLike a && typeLike b+typeLike _ = False++transE :: E -> TM Doc+transE (EError s _) = mparen $ return (text "error" <+> tshow s)+transE (EError s _) = mparen $ return (text "error__" <+> tshow s <> text "#" <+> text "`seq`" <+> text "undefined")+transE (ELit (LitInt num t)) = case cTypeInfoT t of+    ("Char#",_,_) -> return $ text (show $ chr $ fromIntegral num) <> text "#"+    ("Int#",_,_)  | num < 0 -> mparen $ return $ text (show num) <> text "#"+                  | otherwise -> return $ text (show num) <> text "#"+    ("Addr#",_,_) | num == 0 -> return $ text "nullAddr#"+                  | otherwise -> mparen $ return $ text "int2Addr#" <+> text (show num) <> text "#"+    ("Word#",_,_) -> mparen $ text "int2Word# (" <> tshow num <> text "# )"+transE (ELit LitCons { litName = c, litArgs =  ts }) = nparen $ do+    Env { envType = inType } <- ask+    tell mempty { collNames = Set.singleton (c,length ts,inType) }+    ts <- mapM transE ts+    return $ showCon c ts+transE ee | (e,ts@(_:_)) <- fromLam ee  = mparen $ do+    ts' <- mapM transTVr ts+    e <- noParens $ transE e+    return $ text "\\" <> hsep ts' <+> text "->" <+> e+transE (EVar tvr) = do+    --env <- asks envCoerce+    t <- transTVr tvr+    --case tvrIdent tvr `member` env of+    case hasBoxes (tvrType tvr) of+        False -> return t+        True -> mparen $ return $ text "unsafeCoerce#" <+> t+transE ee | (e,es@(_:_)) <- fromAp ee = mparen $ do+    e <- transE e+    es <- mapM transE es+    return (hsep (e:es))+transE ELetRec { eDefs = ds, eBody = e } = mparen $ do+    --local (\e -> e { envCoerce = envCoerce e `mappend` fromList [ tvrIdent t | (t,_) <- ds, hasBoxes (tvrType t)] }) $ do+    ds' <- flip mapM ds $ \ (tvr,e) -> do+        let (b,bs) = fromLam e+        tt <- noParens $ transType (tvrType tvr)+        t <- transTVr tvr+        bs <- mapM transTVr bs+        e <- case hasBoxes (tvrType tvr) of+            False -> noParens $ transE b+            True -> do+                t <- transE b+                return $ text "unsafeCoerce#" <+> t+        return (t <+> text "::" <+> tt <> semi $$ hsep (t:bs) <+> text "=" <+> e)+    e <- noParens $ transE e+    return (text "let {" $$ nest 4 (vcat (punctuate (text ";") ds')) $$ text "} in" <+> e)+transE ECase { eCaseBind = TVr { tvrIdent = 0, tvrType = tt }, eCaseScrutinee = scrut, eCaseDefault = Just body, eCaseAlts = [] } | isLifted tt = mparen $ do+    scrut <- transE scrut+    body <- transE body+    return (scrut <+> text "`seq`" <+> body)+transE ECase { eCaseBind = bind, eCaseScrutinee = scrut, eCaseDefault = md, eCaseAlts = as } = mparen $ do+    scrut <- noParens $ transE scrut+    let dobind = 0 /= tvrIdent bind+    b <- transTVr bind+    md <- T.mapM transE md+    let md' = flip fmap md $ \e ->  b <+> text "->" <+> if dobind && isLifted (getType bind) then text "seq" <+> b <+> e else e+    as <- mapM (transAlt dobind b) as+    let alts = as ++ maybeToMonad md'+    return (text "case" <+> scrut <+> text "of {" $$ nest 4  (vcat (punctuate semi alts)) $$ text "}")+transE e | Just (e',_) <- from_unsafeCoerce e = mparen $ do+    e' <- transE e'+    return (text "unsafeCoerce#" <+> e')+transE e@(EPrim (APrim (PrimPrim prim) _) args _) = case (unpackPS prim,args) of+    ("dependingOn",[x,_y])   -> transE x  -- XXX+    (fs,args) | Just ghcprim <- lookup fs ghcPrimTable -> mparen $ mapM transE args >>= \args' -> return $ hsep (text ghcprim:args')+    _ -> mparen $ return $ text "error" <+> tshow ("ToHs.Error: " ++ show e)+--transE (EPrim (APrim Operator { primOp = "-", primRetType = rt } _) [x] _) = mparen $ do+--    x <- transE x+--    return (hsep [text "negateInt#",x])+--transE (EPrim (APrim Operator { primOp = op, primRetType = rt } _) [x,y] _) | Just z <- op2Table (op,rt) = mparen $ do+--    x <- transE x+--    y <- transE y+--    return (hsep [text z,x,y])+--transE (EPrim (APrim Operator { primOp = op, primArgTypes = [at,_] } _) [x,y] _) | Just z <- op2TableCmp (op,showCType at) = mparen $ do+--    x <- transE x+--    y <- transE y+--    return $ text "fromBool" <+> (parens $ hsep [text z,x,y])+transE (EPrim (APrim CConst { primConst = ('"':rs) } _) [] _) = return (text ('"':rs) <> text "#")+transE (EPrim (APrim (PrimString ss)  _) [] _) = return (tshow ss <> text "#")+transE (EPrim (APrim PrimTypeInfo { primArgType = at, primTypeInfo = c }  _) [] _) = ans where+    Just pi = primitiveInfo at+    ans = case c of+        PrimSizeOf -> return $ tshow (primTypeSizeOf pi) <> char '#'++transE (EPrim (APrim Peek { primArgType = at } _) [w,x] _) = mparen ans where+    ans = do+        w <- transE w+        x <- transE x+        return (text func <+> x <+> text "0#" <+> w)+    (tt,_,_) = cTypeInfo at+    Just pi = primitiveInfo at+    size = primTypeSizeOf pi * 8+    sign = primTypeIsSigned pi+    func = case tt of+        "Char#" -> "readWideCharOffAddr#"+        "Addr#" -> "readAddrOffAddr#"+        "Int#" -> "readInt" ++ show size ++ "OffAddr#"+        "Word#" -> "readWord" ++ show size ++ "OffAddr#"+transE (EPrim (APrim Peek { primArgType = at } _) [x] (ELit LitCons { litName = n })) = mparen $ ans where+    ans = do x <- ans'; castVal at (show n) x+    ans' = mparen $ do+        x <- transE x+        return (text func <+> x <+> text "0#")+    (tt,_,_) = cTypeInfo at+    Just pi = primitiveInfo at+    size = primTypeSizeOf pi * 8+    sign = primTypeIsSigned pi+    func = case tt of+        "Char#" -> "indexWideCharOffAddr#"+        "Addr#" -> "indexAddrOffAddr#"+        "Int#" -> "indexInt" ++ show size ++ "OffAddr#"+        "Word#" -> "indexWord" ++ show size ++ "OffAddr#"+transE (EPrim (APrim Poke { primArgType = at } _) [w,ptr,v] _) = mparen ans where+    ans = do+        w <- transE w+        ptr <- transE ptr+        v <- transE v+        return (text func <+> ptr <+> text "0#" <+> v <+> w)+    Just pi = primitiveInfo at+    size = primTypeSizeOf pi * 8+    sign = primTypeIsSigned pi+    (tt,_,_) = cTypeInfo at+    func = case tt of+        "Char#" -> "writeWideCharOffAddr#"+        "Addr#" -> "writeAddrOffAddr#"+        "Int#" -> "writeInt" ++ show size ++ "OffAddr#"+        "Word#" -> "writeWord" ++ show size ++ "OffAddr#"+transE (EPrim (APrim (AddrOf addr) _) [] _) = mparen $ do+    tell mempty { collPrims = Set.singleton (AddrOf addr) }+    return (text $ "unPtr addr_" ++ mangleIdent (unpackPS addr))++transE (EPrim (APrim func@Func {} _) xs _) = mparen $ do+    tell mempty { collPrims = Set.singleton func }+    xs <- mapM transE xs+    return (hsep (text (cfuncname func):xs))+--transE (EPrim (APrim cast@CCast { primArgType = at, primRetType = rt } _) [x] _) = mparen $ transE x >>= \x ->  castVal at rt x++transE e = mparen $ return $ text "error" <+> tshow ("ToHs.Error: " ++ show e)++ghcPrimTable = [+    ("newWorld__","newWorld__"),+    ("catch__","catch#"),+    ("raiseIO__","raiseIO#"),+    ("newRef__","newMutVar#"),+    ("readRef__","readMutVar#"),+    ("writeRef__","writeMutVar#"),+    ("newMutArray__","newArray#"),+    ("readArray__","readArray#"),+    ("writeArray__","writeArray#"),+    ("indexArray__","indexArray#"),+    ("unsafeFreezeArray__","unsafeFreezeArray#"),+    ("alloca__","alloca__")+    ]++castVal :: ExtType -> ExtType -> Doc -> TM Doc+castVal at rt x = case (showCType at,showCType rt) of+        (a,b) | a == b -> return x+        z | Just co <- lookup z coercions -> mparen $ return (text co <+> x)+        xs -> fail $ "unknown coercion: " ++ show xs+    where+    coercions = [+        (("Int#","Char#"),"chr#"),+        (("Char#","Int#"),"ord#"),+        (("Addr#","Int#"),"addr2Int#"),+        (("Int#","Addr#"),"int2Addr#"),+        (("Word#","Int#"),"word2Int#"),+        (("Int#","Word#"),"int2Word#"),+        (("Char#","Word#"),"char2Word__"),+        (("Word#","Char#"),"word2Char__"),+        (("Addr#","Word#"),"addr2Word__"),+        (("Word#","Addr#"),"word2Addr__")+        ]++cfuncname Func { funcName = fn, funcIOLike = iol, primArgTypes = as, primRetType = r  } =  text $ ("func_" ++ (if iol then "io" else "pure") ++ "_" ++ unpackPS fn ++ intercalate "_" (r:as))++hasBoxes e = or $ execWriter (f e) where+    f e | e == tBox = tell [True] >> return e+    f e = emapEGH f f f e++op2Table (op,rt) = lookup (showCType rt) table >>= lookup op where+    table = [ ("Int#",intTable),("Word#",wordTable),("Addr#",addrTable)]+    intTable = [+        ("+","(+#)"),+        ("-","(-#)"),+        ("*","(*#)"),+        ("%","remInt#"),+        ("/","quotInt#")+        ]+    wordTable = [+        ("+","plusWord#"),+        ("-","minusWord#"),+        ("*","timesWord#"),+        ("%","remWord#"),+        ("/","quotWord#")+        ]+    addrTable = [ ("+","plusAddr__") ]++op2TableCmp (op,rt) = lookup rt table >>= lookup op where+    table = [ ("Int#",intTable), ("Char#",charTable), ("Addr#",addrTable),("Word#",wordTable)]+    intTable = [+        (">","(>#)"),+        ("==","(==#)"),+        ("<","(<#)"),+        (">=","(>=#)"),+        ("<=","(<=#)")+        ]+    charTable = [+        (">","gtChar#"),+        ("==","eqChar#"),+        ("<","ltChar#"),+        (">=","gteChar#"),+        ("<=","lteChar#")+        ]+    addrTable = [+        (">","gtAddr#"),+        ("==","eqAddr#"),+        ("<","ltAddr#"),+        (">=","gteAddr#"),+        ("<=","lteAddr#")+        ]+    wordTable = [+        (">","gtWord#"),+        ("==","eqWord#"),+        ("<","ltWord#"),+        (">=","gteWord#"),+        ("<=","lteWord#")+        ]++transAlt :: Bool -> Doc -> Alt E -> TM Doc+transAlt dobind b (Alt LitInt { litNumber = i, litType = tt } e) = do+    let (t,_,_) = cTypeInfoT tt+    e <- noParens $ transE e+    case t of+        "Int#" -> return $ (if dobind then b <> char '@' else empty) <> tshow i <> text "#" <+> text "->" <+> e+        "Char#" -> return $ (if dobind then b <> char '@' else empty) <> text (show $ chr $ fromIntegral i) <> text "#" <+> text "->" <+> e+        _ -> do+            let bvar = if dobind then b else text "_bvar"+                Just eq = op2TableCmp ("==",t)+            v <- transE (ELit (LitInt i tt))+            return (bvar <+> text "|" <+> text eq <+> bvar <+> v <+> text "->" <+> e)+transAlt dobind b (Alt LitCons { litName = c, litArgs = ts } e) = do+    tell mempty { collNames = Set.singleton (c,length ts,False) }  -- XXX this shouldn't be needed+    ts <- mapM transTVr ts+    e <- noParens $ transE e+    return ( (if dobind then b <> char '@' else empty) <> showCon c ts <+> text "->" <+> e)++transTVr :: TVr -> TM Doc+transTVr TVr { tvrIdent = 0 } = return $ char '_'+transTVr tvr = return (text $ 'v':mangleIdent (pprint tvr))++mangleIdent xs =  concatMap f xs where+        f '.' = "__"+        f '@' = "_a"+        f ',' = "_c"+        f '(' = "_L"+        f ')' = "_R"+        f '$' = "_d"+        f '%' = "_P"+        f '#' = "_h"+        f '/' = "_s"+        f '=' = "_e"+        f '+' = "_p"+        f '-' = "_m"+        f '!' = "_b"+        f '>' = "_r"+        f '<' = "_l"+        f '\'' = "_t"+        f '_' = "_u"+        f c | isAlphaNum c = [c]+        f c = '_':'x':showHex (ord c) ""+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Monoid Collect where+    mempty = Coll mempty mempty+    mappend (Coll aa ab) (Coll aa' ab') = Coll (mappend aa aa')(mappend ab ab')++--  Imported from other files :-
+ drift_processed/E/Type.hs view
@@ -0,0 +1,333 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/Type.hs" #-}+-- | The definitions related to jhc core++module E.Type where++import Data.Foldable hiding(concat)+import Data.Traversable++import C.Prims+import Cmm.Number+import Doc.DocLike hiding((<$>))+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import StringTable.Atom+import Util.Gen+import qualified Info.Info as Info++{- @Internals++# Jhc core normalized forms++Jhc core has a number of 'normalized forms' in which certain invarients are+met. many routines expect code to be in a certain form, and guarentee theier+output is also in a given form. The type system also can change with each form+by adding/removing terms from the PTS axioms and rules.++normalized form alpha+: There are basically no restrictions other than the code is typesafe, but+certain constructs that are checked by the type checker are okay when they+wouldn't otherwise be. In particular, 'newtype' casts still exist at the data+level.  'enum' scrutinizations are creations may be in terms of the virtual+constructors rather than the internal representations. let may bind unboxed+values, which is normaly not allowed.++normalized form beta+: This is like alpha except all data type constructors and case scrutinizations+are in their final form. As in, newtype coercions are removed, Enums are+desugared etc. also, 'let' bindings of unboxed values are translated to the+appropriate 'case' statements. The output of E.FromHs is in this form.++normalized form blue+: This is the form that most routines work on.++normalized form larry+: post lambda-lifting++normalized form mangled+: All polymorphism has been replaced with subtyping++-}++-- the type of a supercombinator+data Comb = Comb {+    combHead :: TVr,+    combBody :: E,+    combRules :: [Rule]+    }++instance HasProperties Comb where+    modifyProperties f comb = combHead_u (modifyProperties f) comb+    getProperties comb = getProperties $ combHead comb+    putProperties p comb = combHead_u (putProperties p) comb++instance HasProperties TVr where+    modifyProperties f = tvrInfo_u (modifyProperties f)+    getProperties = getProperties . tvrInfo+    putProperties prop =  tvrInfo_u (putProperties prop)++combBody_u f r@Comb{combBody  = x} = r{combBody = f x}+combHead_u f r@Comb{combHead  = x} = r{combHead = f x}+combRules_u f r@Comb{combRules  = x} = cp r{combRules = fx} where+    cp = if null fx then unsetProperty PROP_HASRULE else setProperty PROP_HASRULE+    fx = f x++combBody_s v =  combBody_u  (const v)+combHead_s v =  combHead_u  (const v)+combRules_s v =  combRules_u  (const v)++emptyComb = Comb { combHead = tvr, combBody = Unknown, combRules = [] }+combIdent = tvrIdent . combHead+combArgs  = snd . fromLam . combBody+combABody = fst . fromLam . combBody+combBind b = (combHead b,combBody b)+bindComb (t,e) = combHead_s t . combBody_s e $ emptyComb+combTriple comb = (combHead comb,combArgs comb,combABody comb)+combTriple_s (t,as,e) comb = comb { combHead = t, combBody = Prelude.foldr ELam e as }++data RuleType = RuleSpecialization | RuleUser | RuleCatalyst+    deriving(Eq)++-- a rule in its user visible form++data Rule = Rule {+    ruleHead :: TVr,+    ruleBinds :: [TVr],+    ruleArgs :: [E],+    ruleNArgs :: {-# UNPACK #-} !Int,+    ruleBody :: E,+    ruleType :: RuleType,+    ruleUniq :: (Module,Int),+    ruleName :: Atom+    }++data ARules = ARules {+    aruleFreeVars :: IdSet,+    aruleRules :: [Rule]+    }++data Lit e t = LitInt { litNumber :: Number, litType :: t }+    | LitCons  { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E }+    deriving(Eq,Ord,Functor,Foldable,Traversable)+        {-!derive: is !-}++--------------------------------------+-- Lambda Cube (it's just fun to say.)+-- We are now based on a PTS, which is+-- a generalization of the lambda cube+-- see E.TypeCheck for a description+-- of the type system.+--------------------------------------++data ESort =+    EStar         -- ^ the sort of boxed lazy types+    | EBang       -- ^ the sort of boxed strict types+    | EHash       -- ^ the sort of unboxed types+    | ETuple      -- ^ the sort of unboxed tuples+    | EHashHash   -- ^ the supersort of unboxed types+    | EStarStar   -- ^ the supersort of boxed types+    | ESortNamed Name -- ^ user defined sorts+    deriving(Eq, Ord)+    {-! derive: is !-}++data E = EAp E E+    | ELam TVr E+    | EPi TVr E+    | EVar TVr+    | Unknown+    | ESort ESort+    | ELit !(Lit E E)+    | ELetRec { eDefs :: [(TVr, E)], eBody :: E }+    | EPrim Prim [E] E+    | EError String E+    | ECase {+       eCaseScrutinee :: E,+       eCaseType :: E, -- due to GADTs and typecases, the final type of the expression might not be so obvious, so we include it here.+       eCaseBind :: TVr,+       eCaseAlts :: [Alt E],+       eCaseDefault :: (Maybe E),+       eCaseAllFV  :: IdSet+       }+	deriving(Eq, Ord)+    {-! derive: is, from !-}++--instance Functor (Lit e) where+--    fmap f x = runIdentity $ fmapM (return . f) x++--instance FunctorM (Lit e) where+--    fmapM f x = case x of+--        LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } -> do  e <- f e; return LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af }+--        LitInt i t -> do t <- f t; return $ LitInt i t++instance Show ESort where+    showsPrec _ EStar = showString "*"+    showsPrec _ EHash = showString "#"+    showsPrec _ EStarStar = showString "**"+    showsPrec _ EHashHash = showString "##"+    showsPrec _ ETuple = showString "(#)"+    showsPrec _ EBang = showString "!"+    showsPrec _ (ESortNamed n) = shows n++instance (Show e,Show t) => Show (Lit e t) where+    showsPrec p (LitInt x t) = showParen (p > 10) $  shows x <> showString "::" <> shows t+    showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t++instance Show a => Show (TVr' a) where+    showsPrec n TVr { tvrIdent = eid, tvrType = e} | eid == emptyId = showParen (n > 10) $ showString "_::" . shows e+    showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of+        Just n -> shows n . showString "::" . shows e+        Nothing  -> shows x . showString "::" . shows e++type TVr = TVr' E+data TVr' e = TVr { tvrIdent :: !Id, tvrType :: e, tvrInfo :: Info.Info }+    deriving(Functor,Foldable,Traversable)+        {-!derive: update !-}++data Alt e = Alt (Lit TVr e) e+    deriving(Eq,Ord)++instance Eq TVr where+    (==) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i == i'+    (/=) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i /= i'++instance Ord TVr where+    compare (TVr { tvrIdent = x }) (TVr { tvrIdent = y }) = compare x y+    x < y = tvrIdent x < tvrIdent y+    x > y = tvrIdent x > tvrIdent y+    x >= y = tvrIdent x >= tvrIdent y+    x <= y = tvrIdent x <= tvrIdent y++-- simple querying routines+altHead :: Alt E -> Lit () ()+altHead (Alt l _) = litHead  l++litHead :: Lit a b -> Lit () ()+litHead (LitInt x _) = LitInt x ()+litHead LitCons { litName = s, litAliasFor = af } = litCons { litName = s, litType = (), litAliasFor = af }++litBinds (LitCons { litArgs = xs } ) = xs+litBinds _ = []++patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr emptyId (EVar a)) (EVar b)+patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af }+patToLitEE (LitInt x t) = ELit $ LitInt x t++caseBodies :: E -> [E]+caseBodies ec = [ b | Alt _ b <- eCaseAlts ec] ++ maybeToMonad (eCaseDefault ec)+casePats ec =  [ p | Alt p _ <- eCaseAlts ec]+caseBinds ec = eCaseBind ec : concat [ xs  | LitCons { litArgs = xs } <- casePats ec]++-- | extract out EAp nodes a value and the arguments it is applied to.+fromAp :: E -> (E,[E])+fromAp e = f [] e where+    f as (EAp e a) = f (a:as) e+    f as e  =  (e,as)++-- | deconstruct EPi terms, getting function argument types.++fromPi :: E -> (E,[TVr])+fromPi e = f [] e where+    f as (EPi v e) = f (v:as) e+    f as e  =  (e,reverse as)++-- | deconstruct ELam term.++fromLam :: E -> (E,[TVr])+fromLam e = f [] e where+    f as (ELam v e) = f (v:as) e+    f as e  =  (e,reverse as)++litCons = LitCons { litName = error "litName: name not set", litArgs = [], litType = error "litCons: type not set", litAliasFor = Nothing }++-----------------+-- E constructors+-----------------++eStar :: E+eStar = ESort EStar++eHash :: E+eHash = ESort EHash++tVr x y = tvr { tvrIdent = x, tvrType = y }+tvr = TVr { tvrIdent = emptyId, tvrType = Unknown, tvrInfo = Info.empty }++--  Imported from other files :-+{-* Generated by DrIFT : Look, but Don't Touch. *-}+isLitInt (LitInt _ _) = True+isLitInt _ = False+isLitCons (LitCons _ _ _ _) = True+isLitCons _ = False++isEStar (EStar) = True+isEStar _ = False+isEBang (EBang) = True+isEBang _ = False+isEHash (EHash) = True+isEHash _ = False+isETuple (ETuple) = True+isETuple _ = False+isEHashHash (EHashHash) = True+isEHashHash _ = False+isEStarStar (EStarStar) = True+isEStarStar _ = False+isESortNamed (ESortNamed _) = True+isESortNamed _ = False++isEAp (EAp _ _) = True+isEAp _ = False+isELam (ELam _ _) = True+isELam _ = False+isEPi (EPi _ _) = True+isEPi _ = False+isEVar (EVar _) = True+isEVar _ = False+isUnknown (Unknown) = True+isUnknown _ = False+isESort (ESort _) = True+isESort _ = False+isELit (ELit _) = True+isELit _ = False+isELetRec (ELetRec _ _) = True+isELetRec _ = False+isEPrim (EPrim _ _ _) = True+isEPrim _ = False+isEError (EError _ _) = True+isEError _ = False+isECase (ECase _ _ _ _ _ _) = True+isECase _ = False++fromEAp (EAp aa ab) = return (aa,ab)+fromEAp _ = fail "fromEAp"+fromELam (ELam aa ab) = return (aa,ab)+fromELam _ = fail "fromELam"+fromEPi (EPi aa ab) = return (aa,ab)+fromEPi _ = fail "fromEPi"+fromEVar (EVar aa) = return (aa)+fromEVar _ = fail "fromEVar"+fromUnknown (Unknown) = return ()+fromUnknown _ = fail "fromUnknown"+fromESort (ESort aa) = return (aa)+fromESort _ = fail "fromESort"+fromELit (ELit aa) = return (aa)+fromELit _ = fail "fromELit"+fromELetRec (ELetRec aa ab) = return (aa,ab)+fromELetRec _ = fail "fromELetRec"+fromEPrim (EPrim aa ab ac) = return (aa,ab,ac)+fromEPrim _ = fail "fromEPrim"+fromEError (EError aa ab) = return (aa,ab)+fromEError _ = fail "fromEError"+fromECase (ECase aa ab ac ad ae af) = return (aa,ab,ac,ad,ae,af)+fromECase _ = fail "fromECase"++tvrIdent_u f r@TVr{tvrIdent  = x} = r{tvrIdent = f x}+tvrInfo_u f r@TVr{tvrInfo  = x} = r{tvrInfo = f x}+tvrType_u f r@TVr{tvrType  = x} = r{tvrType = f x}+tvrIdent_s v =  tvrIdent_u  (const v)+tvrInfo_s v =  tvrInfo_u  (const v)+tvrType_s v =  tvrType_u  (const v)++--  Imported from other files :-
+ drift_processed/E/TypeCheck.hs view
@@ -0,0 +1,566 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/E/TypeCheck.hs" #-}+module E.TypeCheck(+    canBeBox,+    eAp,+    inferType,+    infertype,+    typecheck,+    match,+    sortSortLike,+    sortKindLike,+    sortTermLike,+    sortTypeLike,+    typeInfer,+    typeInfer'+    ) where++import Control.Monad.Reader+import Control.Monad.Writer+import qualified Data.Map as Map++import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.E+import E.Eval(strong)+import E.Subst+import GenUtil+import Name.Id+import Name.Name+import Name.Names+import Support.CanType+import Util.ContextMonad+import Util.SetLike+import qualified Util.Seq as Seq+import {-# SOURCE #-} DataConstructors+import {-# SOURCE #-} E.Show++{-@Internals++# Ajhc Core Type System++Ajhc's core is based on a pure type system. A pure type system (also called a+PTS) is actually a parameterized set of type systems. Ajhc's version is+described by the following.++    Sorts  = (*, !, **, #, (#), ##, □)+    Axioms = (*:**, #:##, !:**, **:□, ##:□)++    -- sort kind+    *   is the kind of boxed values+    !   is the kind of boxed strict values+    #   is the kind of unboxed values+    (#) is the kind of unboxed tuples+    -- sort superkind+    **  is the superkind of all boxed value+    ##  is the superkind of all unboxed values+    -- sort box+    □   superkinds inhabit this++    in addition there exist user defined kinds, which are always of supersort ##++The following Rules table shows what sort of abstractions are allowed, a rule+of the form (A,B,C) means you can have functions of things of sort A to things+of sort B and the result is something of sort C. _Function_ in this context+subsumes both term and type level abstractions.++Notice that functions are always boxed, but may be strict if they take an+unboxed tuple as an argument.  When a function is strict it means that it is+represented by a pointer to code directly, it cannot be a suspended value that+evaluates to a function.++These type system rules apply to lambda abstractions. It is possible that data+constructors might exist that cannot be given a type on their own with these+rules, even though when fully applied it has a well formed type. An example+would be unboxed tuples. This presents no difficulty as one concludes correctly+that it is a type error for these constructors to ever appear when not fully+saturated with arguments.++    as a shortcut we will use *# to mean every combination involving * and #, and so forth.+    for instance, (*#,*#,*) means the set (*,*,*) (#,*,*) (*,#,*) (#,#,*)++    Rules =+       (*#!,*#!,*)  -- functions from values to values are boxed and lazy+       (*#!,(#),*)  -- functions from values to unboxed tuples are boxed and lazy+       ((#),*#!,!)  -- functions from unboxed tuples to values are boxed and strict+       ((#),(#),!)  -- functions from unboxed tuples to unboxed tuples are boxed and strict+       (**,*,*)     -- may have a function from an unboxed type to a value+       (**,#,*)+       (**,!,*)+       (**,**,**)  -- we have functions from types to types+       (**,##,##)  -- MutArray_ :: * -> #+       (##,##,##)  -- Complex_ :: # -> #++    The defining feature of boxed values is++    _|_ :: t iff t::*++    This PTS is functional but not injective++The PTS can be considered stratified into the following levels++    □                - sort box+    **,##,           - sort superkind+    *,#,(#),!        - sort kind+    Int,Bits32_,Char - sort type+    3,True,"bob"     - sort value++## On boxed kinds++The boxed kinds (* and !) represent types that have a uniform run time+representation. Due to this, functions may be written that are polymorphic in types of these kinds.+Hence the rules of the form (**,?,?), allowing taking types of boxed kinds as arguments.++the unboxed kind # is inhabited with types that have their own specific run+time representation. Hence you cannot write functions that are polymorphic in+unboxed types++## On sort box, the unboxed tuple, and friends++Although sort box does not appear in the code, it is useful from a theoretical+point of view to talk about certain types such as the types of unboxed tuples.+Unboxed tuples may have boxed and unboxed arguments, without sort box it would+be impossible to express this since it must be superkind polymorphic. sort box+allows one to express this as (in the case of the unboxed 2-tuple)++    ∀s1:□ ∀s2:□ ∀k1:s1 ∀k2:s2 ∀t1:k1 ∀t2:k2 . (# t1, t2 #)++However, although this is a valid typing of what it would mean if a unboxed+tuple were not fully applied, since we do not have any rules of form (##,?,?) or+(□,?,?) this type obviously does not typecheck. Which is what enforces the+invarient that unboxed tuples are always fully applied, and is also why we do+not need a code representation of sort box.++### Do we need a superbox?++You will notice that if you look at the axioms involving the sorts, you end up+with a disjoint graph++             □             - the box+            / \+          **   ##          - superkind+          /\     \+         *  !     #   (#)  - kind++This is simply due to the fact that nothing is polymorphic in unboxed tuples of+kind (#) so we never need to refer to any super-sorts of them. We can add sorts+(##),(□) and □□ to fill in the gaps, but since these sorts will never appear in+code or discourse, we will ignore them from now on.++               □□            - sort superbox+              /  \+             □    (□)        - sort box+            / \      \+          **   ##     (##)   - sort superkind+          /\     \    |+         *  !     #   (#)    - sort kind++-}++ptsAxioms :: Map.Map ESort ESort+ptsAxioms = Map.fromList [+    (EStar,EStarStar),+    (EBang,EStarStar),+    (EHash,EHashHash),+    (ETuple,EHashHash)+    ]++ptsRulesMap :: Map.Map (ESort,ESort) ESort+ptsRulesMap = Map.fromList [ ((a,b),c) | (as,bs,c) <- ptsRules, a <- as, b <- bs  ] where+    starHashBang = [EStar,EHash,EBang]+    ptsRules = [+        (starHashBang,ETuple:starHashBang,EStar),+        ([ETuple],ETuple:starHashBang,EBang),+        ([EStarStar],starHashBang,EStar),+        ([EStarStar],[EStarStar],EStarStar),+        ([EStarStar],[EHashHash],EHashHash),+        ([EHashHash],[EHashHash],EHashHash)+        ]++canBeBox x | getType (getType x) == ESort EStarStar = True+canBeBox _ = False++tBox = mktBox eStar++monadicLookup key m = case Map.lookup key m of+    Just x  -> return x+    Nothing -> fail "Key not found"++-- Fast (and lazy, and perhaps unsafe) typeof+instance CanType E where+    type TypeOf E = E+    getType (ESort s) = ESort $ getType s+    getType (ELit l) = getType l+    getType (EVar v) =  getType v+    getType e@(EPi TVr { tvrType = a } b)+        | isUnknown typa || isUnknown typb = Unknown+        | otherwise = maybe (error $ "E.TypeCheck.getType: " ++ show (e,getType a,getType b)) ESort $ do+            ESort s1 <- return $ getType a+            ESort s2 <- return $ getType b+            monadicLookup (s1,s2) ptsRulesMap+        where typa = getType a; typb = getType b+    getType (EAp (ELit LitCons { litType = EPi tvr a }) b) = getType (subst tvr b a)+    getType (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = getType (foldl eAp af (litArgs lc ++ [b]))+    getType (EAp (EPi tvr a) b) = getType (subst tvr b a)+    getType e@(EAp a b) = ans where+        ans = if isUnknown typa then Unknown else if a == tBox || typa == tBox then tBox else (case a of+            (ELit LitCons {}) -> error $ "getType: application of type alias " ++ (render $ parens $ ePretty e)+            _ -> eAp typa b)+        typa = getType a+    getType (ELam (TVr { tvrIdent = x, tvrType =  a}) b) = EPi (tVr x a) (getType b)+    getType (ELetRec _ e) = getType e+    getType ECase {eCaseType = ty} = ty+    getType (EError _ e) = e+    getType (EPrim _ _ t) = t+    getType Unknown = Unknown++instance CanType ESort where+    type TypeOf ESort = ESort+    getType (ESortNamed _) = EHashHash+    getType s = case Map.lookup s ptsAxioms of+        Just s -> s+        Nothing -> error $ "getType: " ++ show s+instance CanType TVr where+    type TypeOf TVr = E+    getType = tvrType+instance CanType (Lit x t) where+    type TypeOf (Lit x t) = t+    getType l = litType l+instance CanType e => CanType (Alt e) where+    type TypeOf (Alt e) = TypeOf e+    getType (Alt _ e) = getType e++sortSortLike (ESort s) = isEHashHash s || isEStarStar s+sortSortLike _ = False++sortKindLike (ESort s) =  not (isEHashHash s) && not (isEStarStar s)+sortKindLike e = sortSortLike (getType e)++sortTypeLike ESort {} = False+sortTypeLike e = sortKindLike (getType e)++sortTermLike ESort {} = False+sortTermLike e = sortTypeLike (getType e)++withContextDoc s a = withContext (render s) a++-- | Perform a full typecheck, evaluating type terms as necessary.++inferType :: (ContextMonad m, ContextOf m ~ String) => DataTable -> [(TVr,E)] -> E -> m E+inferType dataTable ds e = rfc e where+    inferType' ds e = inferType dataTable ds e+    prettyE = ePretty+    rfc e =  withContextDoc (text "fullCheck:" </> prettyE e) (fc e >>= strong')+    rfc' nds e = withContextDoc (text "fullCheck':" </> prettyE e) (inferType' nds e)+    strong' e = withContextDoc (parens $ text "Strong:" </> prettyE e) $ strong ds e+    fc s@(ESort _) = return $ getType s+    fc (ELit lc@LitCons {}) | let lc' = updateLit dataTable lc, litAliasFor lc /= litAliasFor lc' = fail $ "Alias not correct: " ++ show (lc, litAliasFor lc')+    fc (ELit LitCons { litName = n, litArgs = es, litType =  t}) | nameType n == TypeConstructor, Just _ <- fromUnboxedNameTuple n = do+        withContext ("Checking Unboxed Tuple: " ++ show n) $ do+        -- we omit kind checking for unboxed tuples+        valid t+        es' <- mapM rfc es+        strong' t+    fc e@(ELit LitCons { litName = n, litArgs = es, litType =  t}) = do+        withContext ("Checking Constructor: " ++ show e) $ do+        valid t+        es' <- mapM rfc es+        t' <- strong' t+        let sts = slotTypes dataTable n t+            les = length es+            lsts = length sts+        withContext ("Checking Args: " ++ show (sts,es')) $ do+        unless (les == lsts || (les < lsts && isEPi t')) $ do+            fail "constructor with wrong number of arguments"+        zipWithM_ eq sts es'+        return t'+    fc e@(ELit _) = let t = getType e in valid t >> return t+    fc (EVar (TVr { tvrIdent = eid })) | eid == emptyId = fail "variable with nothing!"+    fc (EVar (TVr { tvrType =  t})) = valid t >> strong' t+    fc (EPi (TVr { tvrIdent = n, tvrType =  at}) b) = do+        ESort a <- rfc at+        ESort b <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b+        liftM ESort $ monadicLookup (a,b) ptsRulesMap+        --valid at >> rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b+    --fc (ELam tvr@(TVr n at) b) = valid at >> rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b >>= \b' -> (strong' $ EPi tvr b')+    fc (ELam tvr@(TVr { tvrIdent = n, tvrType =  at}) b) = do+        withContext "Checking Lambda" $ do+        valid at+        b' <- withContext "Checking Lambda Body" $ rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b+        withContext "Checking lambda pi" $ strong' $ EPi tvr b'+    fc (EAp (EPi tvr e) b) = rfc (subst tvr b e)+    fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = rfc (EAp (foldl eAp af (litArgs lc)) b)+    fc (EAp a b) = do+        withContextDoc (text "EAp:" </> parens (prettyE a) </> parens (prettyE b)) $ do+            a' <- rfc a+            if a' == tBox then return tBox else strong' (eAp a' b)+    fc (ELetRec vs e) = do+        let ck (TVr { tvrIdent = eid },_) | eid == emptyId = fail "binding of empty var"+            ck (tv@(TVr { tvrType =  t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text  " = ", parens $ prettyE e ])  $ do+                when (getType t == eHash && not (isEPi t)) $ fail $ "Let binding unboxed value: " ++ show (tv,e)+                valid' nds t+                fceq nds e t+            nds = vs ++ ds+        mapM_ ck vs+        when (hasRepeatUnder (tvrIdent . fst) vs) $ fail "Repeat Variable in ELetRec"+        inferType' nds e+        --et <- inferType' nds e+        --strong nds et+    fc (EError _ e) = valid e >> (strong'  e)+    fc (EPrim _ ts t) = mapM_ valid ts >> valid t >> ( strong' t)+    fc ec@ECase { eCaseScrutinee = e@ELit {}, eCaseBind = b, eCaseAlts = as, eCaseType = dt } | sortTypeLike e = do   -- TODO - this is a hack to get around case of constants.+        withContext "Checking typelike pattern binding case" $ do+        et <- rfc e+        withContext "Checking typelike default binding" $ eq et (getType b)+        verifyPats (casePats ec)+        -- skip checking alternatives+        ps <- mapM (strong' . getType) $ casePats ec+        withContext "Checking typelike pattern equality" $  eqAll (et:ps)+        strong' dt+    fc ec@ECase {eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseType = dt } | sortTypeLike e  = do   -- TODO - we should substitute the tested for value into the default type.+        withContext "Checking typelike binding case" $ do+        et <- rfc e+        withContext "Checking typelike default binding" $ eq et (getType b)+        --dt <- rfc d+        --bs <- mapM rfc (caseBodies ec)  -- these should be specializations of dt+        withContext "Checking typelike alternatives" $ mapM_ (calt e) as+        --eqAll bs+        verifyPats (casePats ec)+        ps <- withContext "Getting pattern types" $ mapM (strong' . getType) $ casePats ec+        withContext "checking typelike pattern equality" $ eqAll (et:ps)+        withContext "Evaluating Case Type" $ strong' dt+    fc ec@ECase { eCaseScrutinee =e, eCaseBind = b } = do+        withContext "Checking plain case" $ do+        et <- rfc e+        withContext "Checking default binding" $ eq et (getType b)+        bs <- withContext "Checking case bodies" $ mapM rfc (caseBodies ec)+        ect <- strong' (eCaseType ec)+        withContext "Checking case bodies have equal types" $ eqAll (ect:bs)+        verifyPats (casePats ec)+        ps <- mapM (strong' . getType) $ casePats ec+        withContext "checking pattern equality" $ eqAll (et:ps)+        return ect+    fc Unknown = return Unknown+    --fc e = failDoc $ text "what's this? " </> (prettyE e)+    calt (EVar v) (Alt l e) = do+        let nv =  followAliases undefined (patToLitEE l)+        rfc (subst' v nv e)+    calt _ (Alt _ e) = rfc e+    verifyPats xs = do+        mapM_ verifyPats' xs+        when (hasRepeatUnder litHead xs) $ fail "Duplicate case alternatives"++    verifyPats' LitCons { litArgs = xs } = when (hasRepeatUnder id (filter (/= emptyId) $ map tvrIdent xs)) $ fail "Case pattern is non-linear"+    verifyPats' _ = return ()++    eqAll ts = withContextDoc (text "eqAll" </> list (map prettyE ts)) $ foldl1M_ eq ts+    valid s = valid' ds s+    valid' nds ESort {} = return ()+    valid' nds s+        | Unknown <- s = return ()+        | otherwise =  withContextDoc (text "valid:" <+> prettyE s) (do t <- inferType' nds s;  valid' nds t)+    eq box t2 | boxCompat box t2 = return t2+    eq t1 box | boxCompat box t1 = return t1+   -- box == tBox, canBeBox t2 = return t2+   -- eq t1 box | box == tBox, canBeBox t1 = return t1+    eq Unknown t2 = return t2+    eq t1 Unknown = return t1+    eq t1 t2 = eq' ds t1 t2+    eq' nds t1 t2 = do+        e1 <- strong nds (t1)+        e2 <- strong nds (t2)+        case typesCompatable e1 e2 of+            Just () -> return (e1)+            Nothing -> failDoc $ text "eq:" <+> align $ vcat [ prettyE (e1), prettyE (e2) ]+    fceq nds e1 t2 = do+        withContextDoc (hsep [text "fceq:", align $ vcat [parens $ prettyE e1,  parens $ prettyE t2]]) $ do+        t1 <- inferType' nds e1+        eq' nds t1 t2+    boxCompat (ELit (LitCons { litName = n }))  t | Just e <- fromConjured modBox n =  e == getType t+    boxCompat _ _ = False++-- This should perform a full typecheck and may take any extra information needed as an extra parameter+class CanTypeCheck a where+    typecheck :: Monad m => DataTable -> a -> m E++infertype :: CanTypeCheck a => DataTable -> a -> E+infertype env a = case typecheck env a of+    Left s -> error $ "infertype: " ++ s+    Right x -> x++instance CanTypeCheck E where+    typecheck dataTable e = case runContextEither $ typeInfer'' dataTable [] e of+        Left ss -> fail $ "\n>>> internal error:\n" ++ unlines ss+        Right v -> return v++instance CanTypeCheck TVr where+    typecheck dt tvr = do+        typecheck dt (getType tvr)+        return $ getType tvr++instance CanTypeCheck (Lit a E) where+    typecheck  dt LitCons { litType = t } = typecheck dt t >> return t+    typecheck  dt LitInt  { litType = t } = typecheck dt t >> return t++-- TODO, types might be bound in scrutinization+instance CanTypeCheck (Alt E) where+    typecheck dt (Alt l e) = typecheck dt l >> typecheck dt e++-- | Determine type of term using full algorithm with substitutions. This+-- should be used instead of 'typ' when let-bound type variables exist or you+-- wish a more thorough checking of types.++typeInfer :: DataTable -> E -> E+typeInfer dataTable e = case runContextEither $ typeInfer'' dataTable [] e of+    Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss)+    Right v -> v++typeInfer' :: DataTable -> [(TVr,E)] -> E -> E+typeInfer' dataTable ds e = case runContextEither $ typeInfer'' dataTable ds e of+    Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss)+    Right v -> v++data TcEnv = TcEnv {+    --tcDefns :: [(TVr,E)],+    tcContext :: [String]+    --tcDataTable :: DataTable+    }++tcContext_u f r@TcEnv{tcContext  = x} = r{tcContext = f x}++newtype Tc a = Tc (Reader TcEnv a)+    deriving(Monad,Functor,MonadReader TcEnv)++instance ContextMonad Tc where+    type ContextOf Tc = String+    withContext s = local (tcContext_u (s:))++{-+tcE :: E -> Tc E+tcE e = rfc e where+    rfc e =  withContextDoc (text "tcE:" </> ePretty e) (fc e >>=  strong')+    strong' e = do+        ds <- asks tcDefns+        withContextDoc (text "tcE.strong:" </> ePretty e) $ strong ds e++    fc s@ESort {} = return $ getType s+    fc (ELit LitCons { litType = t }) = strong' t+    fc e@ELit {} = strong' (getType e)+    fc (EVar TVr { tvrIdent = eid }) | eid == emptyId = fail "variable with nothing!"+    fc (EVar TVr { tvrType =  t}) =  strong' t+    fc (EPi TVr { tvrIdent = n, tvrType = at} b) =  do+        ESort a <- rfc at+        ESort b <- local (tcDefns_u (\ds -> [ d | d@(v,_) <- ds, tvrIdent v /= n ])) $ rfc b+        liftM ESort $ monadicLookup (a,b) ptsRulesMap+    fc (ELam tvr@TVr { tvrIdent = n, tvrType =  at} b) = do+        at' <- strong' at+        b' <- local (tcDefns_u (\ds -> [ d | d@(v,_) <- ds, tvrIdent v /= n ])) $ rfc b+        return (EPi (tVr n at') b')+    fc (EAp (EPi tvr e) b) = do+        b <- strong' b+        rfc (subst tvr b e)+    fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = fc (EAp (foldl eAp af (litArgs lc)) b)+    fc (EAp a b) = do+        a' <- rfc a+        if a' == tBox then return tBox else strong' (eAp a' b)+    fc (ELetRec vs e) = local (tcDefns_u (vs ++)) $ rfc e+    fc (EError _ e) = strong' e+    fc (EPrim _ ts t) = strong' t+    fc ECase { eCaseType = ty } = do+        strong' ty+    fc Unknown = return Unknown+    fc e = failDoc $ text "what's this? " </> (ePretty e)+-}++typeInfer'' :: (ContextMonad m, ContextOf m ~ String) => DataTable -> [(TVr,E)] -> E -> m E+typeInfer'' dataTable ds e = rfc e where+    inferType' ds e = typeInfer'' dataTable ds e+    rfc e =  withContextDoc (text "fullCheck':" </> ePretty e) (fc e >>= strong')+    rfc' nds e =  withContextDoc (text "fullCheck':" </> ePretty e) (inferType' nds e)+    strong' e = withContextDoc (text "Strong':" </> ePretty e) $ strong ds e+    fc s@ESort {} = return $ getType s+    fc (ELit LitCons { litType = t }) = strong' t+    fc e@ELit {} = strong' (getType e)+    fc (EVar TVr { tvrIdent = eid }) | eid == emptyId = fail "variable with nothing!"+    fc (EVar TVr { tvrType =  t}) =  strong' t+    fc (EPi TVr { tvrIdent = n, tvrType = at} b) =  do+        ESort a <- rfc at+        ESort b <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b+        liftM ESort $ monadicLookup (a,b) ptsRulesMap+    fc (ELam tvr@TVr { tvrIdent = n, tvrType =  at} b) = do+        at' <- strong' at+        b' <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b+        return (EPi (tVr n at') b')+    fc (EAp (EPi tvr e) b) = do+        b <- strong' b+        rfc (subst tvr b e)+    fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = fc (EAp (foldl eAp af (litArgs lc)) b)+    fc (EAp a b) = do+        a' <- rfc a+        if a' == tBox then return tBox else strong' (eAp a' b)+    fc (ELetRec vs e) = do+        let nds = vs ++ ds+        --et <- inferType' nds e+        --strong nds et+        inferType' nds e+    fc (EError _ e) = strong' e+    fc (EPrim _ ts t) = strong' t+    fc ECase { eCaseType = ty } = do+        strong' ty+    fc Unknown = return Unknown+    --fc e = failDoc $ text "what's this? " </> (ePretty e)++-- | find substitution that will transform the left term into the right one,+-- only substituting for the vars in the list++match :: Monad m =>+    (Id -> Maybe E)      -- ^ function to look up values in the environment+    -> [TVr]              -- ^ vars which may be substituted+    -> E                  -- ^ pattern to match+    -> E                  -- ^ input expression+    -> m [(TVr,E)]+match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 etherealIds) where+    bvs :: IdSet+    bvs = fromList (map tvrIdent vs)++    un (EAp a b) (EAp a' b') c = do+        un a a' c+        un b b' c+    un (ELam va ea) (ELam vb eb) c = lam va ea vb eb c+    un (EPi va ea) (EPi vb eb) c = lam va ea vb eb c+    un (EPi va ea) (ELit LitCons { litName = ar, litArgs = [x,y], litType = lt}) c | ar == tc_Arrow = do+        un (tvrType va) x c+        un ea y c+    un (EPrim s xs t) (EPrim s' ys t') c | length xs == length ys = do+        sequence_ [ un x y c | x <- xs | y <- ys]+        un t t' c+    un (ESort x) (ESort y) c | x == y = return ()+    un (ELit (LitInt x t1))  (ELit (LitInt y t2)) c | x == y = un t1 t2 c+    un (ELit LitCons { litName = n, litArgs = xs, litType = t })  (ELit LitCons { litName = n', litArgs = ys, litType =  t'}) c | n == n' && length xs == length ys = do+        sequence_ [ un x y c | x <- xs | y <- ys]+        un t t' c++    un (EVar TVr { tvrIdent = i, tvrType =  t}) (EVar TVr {tvrIdent = j, tvrType =  u}) c | i == j = un t u c+    un (EVar TVr { tvrIdent = i, tvrType =  t}) (EVar TVr {tvrIdent = j, tvrType =  u}) c | isEtherealId i || isEtherealId j   = fail "Expressions don't match"+    un (EAp a b) (ELit lc@LitCons { litArgs = bas@(_:_), litType = t }) c = do+        let (al:as) = reverse bas+        un a (ELit lc { litArgs = reverse as, litType = ePi tvr { tvrType = getType al } t }) c+        un b al c+    un (EAp a b) (EPi TVr { tvrType = a1 } a2) c = do+        un a (ELit litCons { litArgs = [a1], litName = tc_Arrow, litType = EPi tvr { tvrType = getType a2 } (getType a1) }) c+        un b a2 c+    un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b c+        | i `member` bvs = tell (Seq.single (tvr,b))+        | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b+    un a (EVar tvr) c | Just b <- lup (tvrIdent tvr), not $ isEVar b = un a b c+    --un a b c | Just a' <- followAlias undefined a = un a' b c+    un a b c | Just b' <- followAlias undefined b = un a b' c++    un a b _ = fail $ "Expressions do not unify: " ++ show a ++ show b+    lam va ea vb eb (c:cs) = do+        un (tvrType va) (tvrType vb) (c:cs)+        un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) cs+    lam _ _ _ _ _ = error "TypeCheck.match: bad."+{-* Generated by DrIFT : Look, but Don't Touch. *-}+--  Imported from other files :-
+ drift_processed/FrontEnd/Class.hs view
@@ -0,0 +1,586 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/Class.hs" #-}+{-# LANGUAGE NoMonoLocalBinds, NamedFieldPuns #-}+module FrontEnd.Class(+    printClassHierarchy,+    instanceToTopDecls,+    ClassHierarchy(),+    augmentClassHierarchy,+    chToClassHead,+    ClassRecord(..),+    ClassType(..),+    instanceName,+    defaultInstanceName,+    checkForDuplicateInstaces,+    printClassSummary,+    findClassInsts,+    findClassRecord,+    asksClassRecord,+    classRecords,+    addInstanceToHierarchy,+    makeClassHierarchy,+    scatterAliasInstances,+    derivableClasses,+    enumDerivableClasses,+    noNewtypeDerivable,+    makeInstanceEnv,+    emptyInstance,+    InstanceEnv(..),+    Inst(..)+    ) where++import Control.Monad.Identity+import Control.Monad.Writer(Monoid(..))+import Data.Generics(mkQ,something)+import Data.List(nub)+import Data.Maybe+import Debug.Trace+import Text.PrettyPrint.HughesPJ(render,Doc())+import Text.Printf+import qualified Data.List+import qualified Data.Map as Map+import qualified Text.PrettyPrint.HughesPJ as PPrint++import Data.Binary+import Doc.DocLike+import Doc.PPrint+import FrontEnd.HsSyn+import FrontEnd.KindInfer+import FrontEnd.SrcLoc+import FrontEnd.Tc.Kind+import FrontEnd.Tc.Type+import FrontEnd.Utils+import FrontEnd.Warning+import Name.Name+import Name.Names+import Options (verbose)+import Support.FreeVars+import Support.MapBinaryInstance+import Support.Tickle+import Util.Gen+import Util.Inst()++type Assump = (Name,Sigma)++data Inst = Inst {+    instSrcLoc  :: SrcLoc,+    instDerived :: !Bool,   -- ^ whether this instance was derived+    instHead    :: Qual Pred,+    instAssocs  :: [(Tycon,[Tyvar],[Tyvar],Sigma)]+    } deriving(Eq,Ord,Show)+    {-! derive: Binary !-}++instance PPrint a (Qual Pred) => PPrint a Inst where+    pprint Inst { instHead = h, instAssocs = [], instDerived = d } = (if d then text "*" else text " ") <> pprint h+    pprint Inst { instHead = h, instAssocs = as, instDerived = d } = (if d then text "*" else text " ") <> pprint h <+> text "where" <$> vcat [ text "    type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma  | (n,_,ts,sigma) <- as]++emptyInstance = Inst { instDerived = False, instSrcLoc = bogusASrcLoc, instHead = error "emptyInstance", instAssocs = [] }++-- augment heirarchy with just instances with full class definitions+augmentClassHierarchy :: ClassHierarchy -> ClassHierarchy -> ClassHierarchy+augmentClassHierarchy (CH full _) (CH res is) = ans where+    ans = CH (Map.mapWithKey f is) is+    f cn _ = r where Just r = Map.lookup cn (Map.union res full)++data ClassType = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias+        deriving(Eq,Ord)++-- Bool is true if data declaration instead of type declaration+data AssociatedType = Assoc !Tycon !Bool [Tyvar] Kind+    deriving(Eq,Show)+    {-! derive: Binary !-}++data ClassRecord = ClassRecord {+    className    :: !Class, -- ^ can be a TypeConstructor if we are a type or data family+    classSrcLoc  :: !SrcLoc,+    classArgs    :: [Tyvar],+    classSupers  :: [Class], -- TODO: should be Pred+    classAlias   :: Maybe (Qual [Pred]),+    classAssumps :: [(Name,Sigma)], -- ^ method signatures+    classAssocs  :: [AssociatedType]+    } deriving (Show,Eq)+    {-! derive: Binary !-}++newtype InstanceEnv = InstanceEnv {+    instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) }++makeInstanceEnv :: ClassHierarchy -> InstanceEnv+makeInstanceEnv (CH _ is) = InstanceEnv $ Map.fromList (concatMap f (Map.toList is)) where+    f (cr,is) = concatMap (g cr) is+    g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == cr = ans where+        ans = [ ((tyconName tc,getTypeHead tt),(is,rs,e)) | (tc,is,rs,e) <- as]+    g cr x = error $  "makeInstanceEnv: " ++ show (cr,x)++getTypeHead th = case fromTAp th of+    (TArrow {},_) -> tc_Arrow+    (TCon c,_) -> tyconName c+    _ -> error $ "getTypeHead: " ++ show th++data ClassHierarchy = CH (Map.Map Class ClassRecord) (Map.Map Class [Inst])++instance Binary ClassHierarchy where+    get = do+        m1 <- getMap+        m2 <- getMap+        return (CH m1 m2)+    put (CH m1 m2) = do+        putMap m1+        putMap m2++instance Monoid ClassHierarchy where+    mempty = CH mempty mempty+    mappend (CH a b) (CH c d) =+        CH (Map.union a c) (Map.unionWith Data.List.union b d)++classRecords :: ClassHierarchy -> [ClassRecord]+classRecords (CH ch _) = Map.elems ch++findClassRecord (CH ch _) cn = case Map.lookup cn ch of+    Nothing -> error $ "findClassRecord: " ++ show cn+    Just n -> n++asksClassRecord (CH ch _) cn f = case Map.lookup cn ch of+    Nothing -> error $ "asksClassRecord: " ++ show cn+    Just n -> f n+findClassInsts (CH _ is) cn = fromMaybe [] (Map.lookup cn is)++showInst :: Inst -> String+showInst = PPrint.render . pprint++aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)]+aHsTypeSigToAssumps kt ~sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where+    Identity typ = hsQualTypeToSigma kt qualType++qualifyMethod :: [HsAsst] -> HsDecl -> HsDecl+qualifyMethod ~[HsAsst c [n]] ~(HsTypeSig sloc names (HsQualType oc t))+    = HsTypeSig sloc names (HsQualType (HsAsst c [n']:oc) t) where+        Just n' = (something (mkQ mzero f)) t+        f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n'+        f _ = mzero++printClassSummary :: ClassHierarchy -> IO ()+printClassSummary (CH h is) = mapM_ f (Map.toList h) where+    --h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ]+    f (cname, ClassRecord { .. }) = do+        putStrLn $ "-- class: " ++ show cname+        let insts = fromMaybe [] (Map.lookup cname is)+        unless (null classSupers) $ putStrLn $ "super classes:" ++ unwords (map show classSupers)+        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))+--        putStrLn ""+--    f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do+--        putStrLn $ "-- class: " ++ show cname+--        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)+--        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))+--        unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes)+--        putStrLn ""++printClassHierarchy :: ClassHierarchy -> IO ()+printClassHierarchy (CH h is) = mapM_ printClassDetails $  Map.toList h where+    printClassDetails :: (Name, ClassRecord) -> IO ()+    printClassDetails (cname, cr) = do+        let args = classArgs cr; supers = classSupers cr;+            methodAssumps = classAssumps cr+            assocs = classAssocs cr+        let insts = fromMaybe [] (Map.lookup cname is)+        putStrLn "..........."+        putStrLn $ "class: " ++ hsep (pprint cname:map pprintParen args)+        putStr $ "super classes:"+        pnone supers $ do putStrLn $ " " ++ (intercalate " " (map show supers))+        putStr $ "instances:"+        pnone insts $  putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)+        when True $ do+            putStr $ "method signatures:"+            pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps)+            putStr $ "associated types:"+            pnone assocs $  putStrLn $ "\n" ++ (unlines $ map (render . passoc) assocs)+        when (isJust (classAlias cr)) $ do+            let Just x = classAlias cr+            putStr $ "alias for:"+            putStrLn (pprint x)+            --Just $ --pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))+        putStr "\n"+    pnone [] f = putStrLn " none"+    pnone xs f = f+    passoc (Assoc nk isData as kt) = text (if isData then "data" else "type") <+>+        pprint nk <+> hsep (map pprint as) <+> text "::" <+> pprint kt++-- this does not check for duplicates, use checkForDuplicateInstaces after all+-- instances have been added to do so.+addInstanceToHierarchy :: Inst -> ClassHierarchy -> ClassHierarchy+addInstanceToHierarchy inst@Inst { instHead = cntxt :=> ~(IsIn className _) } (CH r i) =+    CH r (Map.insertWith Data.List.union className [inst] i)++-- Kind inference has already been done so we don't need to check for kind+-- errors here.+hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst]+hsInstDeclToInst kt (HsInstDecl sloc qType decls)+    = return [emptyInstance { instSrcLoc = sloc, instDerived = False,+        instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }]+   where+   (cntxt, (className, [convertedArgType])) = chToClassHead kt qType+   assocs = [ (tc,as,bs,s) | (tc,as,bs,~(Just s)) <- createInstAssocs kt decls ]+hsInstDeclToInst kt (HsDeclDeriving sloc qType)+        = return [emptyInstance { instSrcLoc = sloc, instDerived = True,+        instHead = cntxt :=> IsIn className convertedArgType }]+   where (cntxt, (className, [convertedArgType])) = chToClassHead kt qType+hsInstDeclToInst _ _ = return []++vtrace s v | False && verbose = trace s v+vtrace s v | otherwise = v++chToClassHead :: KindEnv -> HsClassHead -> ([Pred],(Name,[Type]))+chToClassHead kt qt@HsClassHead { .. }  =+    vtrace ("chToClassHead" <+> show qt) $+    let res = (map (hsAsstToPred kt) hsClassHeadContext,(hsClassHead,+            map (runIdentity . hsTypeToType (kiHsQualType kt (HsQualType hsClassHeadContext (HsTyTuple [])))) hsClassHeadArgs))+    in vtrace ("=" <+> show res) res++createClassAssocs kt decls = [ Assoc (ctc n) False (map ct as) (ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where+    ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt)+    ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt)+    ct _ = error "Class.createClassAssocs: bad1."+    ctype HsTyAssoc = kindStar+    ctype _ = error "Class.createClassAssocs: bad2."+--    ctype t = Just $ runIdentity $ hsTypeToType kt t++createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where+    ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt)+    ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt)+    ct _ = error "Class.createInstAssocs: bad."+    czas ca = let (HsTyCon {},zas) = fromHsTypeApp ca in zas+    ctype HsTyAssoc = Nothing+    ctype t = Just $ runIdentity $ hsTypeToType kt t++fromHsTypeApp t = f t [] where+    f (HsTyApp a b) rs = f a (b:rs)+    f t rs = (t,rs)++instanceToTopDecls :: KindEnv -> ClassHierarchy -> HsDecl -> (([HsDecl],[Assump]))+instanceToTopDecls kt ch@(CH classHierarchy _) (HsInstDecl _ qualType methods)+    = unzip $ concatMap (methodToTopDecls kt [] crecord qualType) $ methodGroups where+    methodGroups = groupEquations (filter (not . isHsPragmaProps) methods)+    (_,(className,_)) = chToClassHead kt qualType+    crecord = case Map.lookup className classHierarchy  of+        Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"+        Just crecord -> crecord+instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ chead methods)+   = unzip $ map (defaultMethodToTopDecls kt methodSigs chead) $ methodGroups where+   className = hsClassHead chead+   --HsQualType _ (HsTyApp (HsTyCon className) _) = qualType+   methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x)  methods)+   methodSigs = case Map.lookup (toName ClassName className) classHierarchy  of+           Nothing -> error $ "defaultInstanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"+           Just sigs -> classAssumps sigs+instanceToTopDecls _ _ _ = mempty++instanceName n t = toName Val ("Instance@",'i':show n ++ "." ++ show t)+defaultInstanceName n = toName Val ("Instance@",'i':show n ++ ".default")+-- aliasDefaultInstanceName :: Name -> Class -> Name+-- aliasDefaultInstanceName n ca = toName Val ("Instance@",'i':show n ++ ".default."++show ca)++methodToTopDecls :: Monad m+    => KindEnv         -- ^ the kindenv+    -> [Pred]          -- ^ random extra predicates to add+    -> ClassRecord     -- ^ the class we are lifting methods from+    -> HsClassHead+    -> (Name, HsDecl)+    -> m (HsDecl,Assump)+methodToTopDecls kt preds crecord qt (methodName, methodDecls) = do+    let (cntxt,(className,[argType])) = chToClassHead kt qt+	newMethodName = instanceName methodName (getTypeHead argType)+    sigFromClass <- case [ s | (n, s) <- classAssumps crecord, n == methodName] of+	    [x] -> return x+	    _ -> fail $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord))+					  ++ " " ++ show  methodName+    let instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType+	renamedMethodDecls = renameOneDecl newMethodName methodDecls+    return (renamedMethodDecls,(newMethodName, instantiatedSig))++defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsClassHead -> (Name, HsDecl) -> (HsDecl,Assump)+defaultMethodToTopDecls kt methodSigs HsClassHead { .. } (methodName, methodDecls)+   = (renamedMethodDecls,(newMethodName,sigFromClass)) where+    newMethodName = defaultInstanceName methodName+    sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of+        [x] -> x+        _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show  methodName+     --  = newMethodSig cntxt newMethodName sigFromClass argType+    renamedMethodDecls = renameOneDecl newMethodName methodDecls++{-+aliasDefaultMethodToTopDecls :: KindEnv -> [Assump] -> Class -> (Name, HsDecl) -> (HsDecl,Assump)+aliasDefaultMethodToTopDecls kt methodSigs aliasName (methodName, methodDecls)+   = (renamedMethodDecls,(newMethodName,sigFromClass)) where+     newMethodName = aliasDefaultInstanceName methodName aliasName+     sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of+         [x] -> x+         _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show  methodName+      --  = newMethodSig cntxt newMethodName sigFromClass argType+     renamedMethodDecls = renameOneDecl newMethodName methodDecls+-}++renameOneDecl :: Name -> HsDecl -> HsDecl+renameOneDecl newName (HsFunBind matches)+   = HsFunBind  (map (renameOneMatch newName) matches)+-- all pattern bindings are simple by this stage+-- (ie no compound patterns)+renameOneDecl newName (HsPatBind sloc (HsPVar patName) rhs wheres)+   = HsPatBind sloc (HsPVar (nameName newName)) rhs wheres+renameOneDecl _ _ = error "Class.renameOneDecl"++renameOneMatch :: Name -> HsMatch -> HsMatch+renameOneMatch newName (HsMatch sloc oldName pats rhs wheres)+   = HsMatch sloc (nameName newName) pats rhs wheres++newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> Type -> Sigma+newMethodSig' kt methodName newCntxt qt' instanceType  = newQualType where+    TForAll _ ((IsIn _ classArg:restContext) :=> t) = qt'+    -- the assumption is that the context is non-empty and that+    -- the class and variable that we are interested in are at the+    -- front of the old context - the method of inserting instance types into+    -- the class hierarchy should ensure this+    --((className, classArg):restContxt) = cntxt+    foo = "_" ++ (show methodName ++ show (getTypeHead instanceType)) ++ "@@"+--    newQualType = everywhere (mkT at) $ tForAll (nub $ freeVars qt) qt++    newQualType = tForAll vs nqt where+        vs = nub $ freeVars nqt+        nqt = map (tickle f) (newCntxt ++ restContext) :=> f t+        f t | t == classArg = f instanceType+        f (TVar t) = TVar (at t)+        f (TForAll ta (ps :=> t)) = tickle f (TForAll (map at ta) (ps :=> t))+        f (TExists ta (ps :=> t)) = tickle f (TExists (map at ta) (ps :=> t))+        f t = tickle f t++    at (Tyvar n k) =  tyvar (updateName (++ foo) n) k+    updateName f n = toName nt (md,f nm) where+         (nt,(md::String,nm)) = fromName n+--    qt = (newCntxt ++ restContext) :=> t+    {-+    qt = (newCntxt ++ restContext) :=> (everywhere (mkT ct) t)+    ct n | n == classArg = instanceType+    ct n =  n+    -}++-- collect assumptions of all class methods++--classMethodAssumps :: ClassHierarchy -> [Assump]+--classMethodAssumps hierarchy = concatMap classAssumps $ classRecords hierarchy++--------------------------------------------------------------------------------++scatterAliasInstances :: ClassHierarchy -> ClassHierarchy+scatterAliasInstances = id+{-+scatterAliasInstances ch =+    let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch]+    --ch `seq` liftIO $ putStrLn ("scatterAliasInstances: " ++ show cas)+        instances = concatMap scatterInstancesOf cas+        ret = foldr (modifyClassRecord $ \cr -> cr+                     { classInsts = [],+                       classMethodMap = Map.fromList [(meth, cls) | cls <- classClasses cr,+                                                                    (meth,_) <- classAssumps (findClassRecord ch cls)]+                     })+                    (ch `mappend` classHierarchyFromRecords instances)+                    (map className cas)+    -- liftIO $ mapM_ print (classRecords ret)+    in ret++scatterInstancesOf :: ClassRecord -> [ClassRecord]+scatterInstancesOf cr = map extract (classClasses cr)+    where+      extract c =+          (newClassRecord c) { classInsts =+                                   [Inst sl d ((cxt ++ [IsIn c2 xs | c2 <- classClasses cr, c2 /= c]) :=> IsIn c xs) []+                                        | Inst sl d (cxt :=> IsIn _ xs) [] <- classInsts cr] }++-}+--------------------------------------------------------------------------------++--failSl sl m = fail $ show sl ++ ": " ++ m++classHierarchyFromRecords rs =+    CH (Map.fromList [ (className x,x)| x <- rs ]) mempty++fromHsTyVar (HsTyVar v) = return v+fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t+fromHsTyVar _ = fail "fromHsTyVar"++-- We give all instance declarations the benefit of the doubt here, assuming+-- they are correct. It is up to the typechecking pass to find any errors.+makeClassHierarchy :: MonadWarn m => ClassHierarchy -> KindEnv -> [HsDecl] -> m ClassHierarchy+makeClassHierarchy (CH ch _is) kt ds = mconcat `liftM` mapM f ds where+    f (HsClassDecl sl chead decls) = do+            let qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)+                newClassContext = [HsAsst className args]+                className = hsClassHead chead+                args = [ a | ~(Just a) <- map fromHsTyVar (hsClassHeadArgs chead) ]+            return $ classHierarchyFromRecords [ClassRecord {+                classArgs,+                classAssocs,+                classAlias = Nothing,+                className = toName ClassName className,+                classSrcLoc = sl,+                classSupers = [ toName ClassName x | ~(HsAsst x _) <- cntxt],+                classAssumps = qualifiedMethodAssumps }]+        where+        cntxt = hsClassHeadContext chead+        classAssocs = createClassAssocs kt decls+        (_,(_,classArgs')) = chToClassHead kt chead+        classArgs = [ v | ~(TVar v) <- classArgs' ]+--    f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do+--        tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl),+--                                 classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)],+--                                 classSrcLoc = hsDeclSrcLoc decl,+--                                 classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)],+--                                 classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)],+--                                 classInsts = [],+--                                 classMethodMap = Map.empty+--                               }]++    f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do+        return $ foldl (flip addInstanceToHierarchy) mempty insts+    f decl@(HsDeclDeriving {}) = hsInstDeclToInst kt decl >>= \insts -> do+        return $ foldl (flip addInstanceToHierarchy) mempty insts+    f _ = return mempty++checkForDuplicateInstaces :: MonadWarn m+    => ClassHierarchy    -- ^ imported class hierarchy+    -> ClassHierarchy    -- ^ locally defined hierarchy+    -> m ClassHierarchy  -- ^ possibly simplified local hierarchy+checkForDuplicateInstaces iCh (CH ch is) = mapM_ f (Map.toList is) >> return (CH ch is) where+    f (className,is) = do+        let is' = findClassInsts iCh className ++ is+            sgu = sortGroupUnderFG fst snd [ ((cn,getTypeHead tt), i) |+                i@Inst { instSrcLoc = sl, instHead = _ :=> IsIn cn tt } <- is' ]+        mapM_ g sgu+    g (_,[_]) = return ()+    g (_,sls) | all instDerived sls = return ()+    g ((ch,th),sls) = warn (instSrcLoc $ head sls) DuplicateInstances $+        printf "instance (%s (%s ..)) defined multiple times: %s"+            (show ch) (show th) (show $ map instSrcLoc sls)++accLen :: Int -> [[a]] -> [(Int, [a])]+accLen width [] = []+accLen width (x:xs) = let newWidth = length x + width in (newWidth, x) : accLen newWidth xs++groupStringsToWidth :: Int -> [String] -> [String]+groupStringsToWidth width ss = groupStringsToWidth' width (accLen 0 ss) where+   groupStringsToWidth' :: Int -> [(Int,String)] -> [String]+   groupStringsToWidth' width [] = []+   groupStringsToWidth' width xs+      = headString : groupStringsToWidth' width (accLen 0 $ map snd rest)+      where+      (headSegments, rest)+         = case span ((<=width).fst) xs of+              ([], ss)     -> ([head ss], tail ss)+              anythingElse -> anythingElse+      headString = concatMap snd headSegments++showListAndSepInWidth :: (a -> String) -> Int -> String -> [a] -> String+showListAndSepInWidth _ _ _ [] = []+showListAndSepInWidth f width sep things = unlines $ groupStringsToWidth width newThings where+   newThings = (map ((\t -> t ++ sep).f) (init things)) ++ [f (last things)]++pretty  :: PPrint Doc a => a -> String+pretty   = render . pprint++{-+nameOfTyCon :: NameType -> HsType -> Name+nameOfTyCon t (HsTyCon n) = toName t n+nameOfTyCon t (HsTyTuple xs) = nameTuple t (length xs)+nameOfTyCon t (HsTyFun _ _) = tc_Arrow+nameOfTyCon _ t = error $ "nameOfTyCon: " ++ show t+-}++groupEquations :: [HsDecl] -> [(Name, HsDecl)]+groupEquations [] = []+groupEquations (HsTypeDecl {}:ds) = groupEquations ds+groupEquations (d:ds) = (getDeclName d, d) : groupEquations ds++derivableClasses ::  [Name]+derivableClasses = [+    class_Eq,+    class_Ord,+    class_Enum,+    class_Bounded,+    class_Show,+    class_Read,+    class_Ix+    ]++-- can be automatically derived when+-- the class is an enumeration+enumDerivableClasses ::  [Name]+enumDerivableClasses = [+    class_Eq,+    class_Ord,+    class_Enum,+    class_Ix+    ]++-- classes that cannot be derived by the generalized+-- newtype deriving mechanism.+noNewtypeDerivable :: [Name]+noNewtypeDerivable = [+    class_Show,+    class_Read+    ]++-- classes that behave identically to their component when they have a single+-- unary constructor but are not newtypes+{-+unaryPassDerivable :: [Name]+unaryPassDerivable = [+    class_Ix,+    class_Eq,+    class_Ord,+    class_Bounded+    ]+-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary Inst where+    put (Inst aa ab ac ad) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    return (Inst aa ab ac ad)++instance Data.Binary.Binary AssociatedType where+    put (Assoc aa ab ac ad) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    return (Assoc aa ab ac ad)++instance Data.Binary.Binary ClassRecord where+    put (ClassRecord aa ab ac ad ae af ag) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+	    Data.Binary.put ae+	    Data.Binary.put af+	    Data.Binary.put ag+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    ae <- get+    af <- get+    ag <- get+    return (ClassRecord aa ab ac ad ae af ag)++--  Imported from other files :-
+ drift_processed/FrontEnd/HsSyn.hs view
@@ -0,0 +1,877 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/HsSyn.hs" #-}+module FrontEnd.HsSyn where++import Data.Binary+import Data.Generics++import C.FFI+import FrontEnd.SrcLoc+import Name.Name+import Name.Names+import Options+import StringTable.Atom+import StringTable.Atom()++instance HasLocation HsAlt where+    srcLoc (HsAlt sl _ _ _) = sl++instance HasLocation HsExp where+    srcLoc (HsCase _ xs) = srcLoc xs+    srcLoc (HsExpTypeSig sl _ _) = sl+    srcLoc (HsLambda sl _ _) = sl+    srcLoc HsError { hsExpSrcLoc = sl } = sl+    srcLoc _ = bogusASrcLoc++hsNameIdent_u f n = mapName (id,f) n+hsIdentString_u f x = f x++type HsName = Name++instance Binary Module where+    get = do+        ps <- get+        return (Module $ fromAtom ps)+    put (Module n) = put (toAtom n)++instance HasLocation HsModule where+    srcLoc x = hsModuleSrcLoc x++data HsModule = HsModule {+    hsModuleName    :: Module,+    hsModuleSrcLoc  :: SrcLoc,+    hsModuleExports :: (Maybe [HsExportSpec]),+    hsModuleImports :: [HsImportDecl],+    hsModuleDecls   :: [HsDecl],+    hsModuleOptions :: [String],+    hsModuleOpt     :: Opt+    }+  {-! derive: update !-}++-- Export/Import Specifications++data HsExportSpec+    = HsEVar HsName                      -- variable+    | HsEAbs HsName                      -- T+    | HsEThingAll HsName                 -- T(..)+    | HsEThingWith HsName [HsName]       -- T(C_1,...,C_n)+    | HsEModuleContents Module           -- module M   (not for imports)+    | HsEQualified NameType HsExportSpec -- class Foo, type Bar, kind ANY+  deriving(Eq,Show)++instance HasLocation HsImportDecl where+    srcLoc x = hsImportDeclSrcLoc x++data HsImportDecl = HsImportDecl {+    hsImportDeclSrcLoc    :: SrcLoc,+    hsImportDeclModule    :: Module,+    hsImportDeclQualified :: !Bool,+    hsImportDeclAs        :: (Maybe Module),+    hsImportDeclSpec      :: (Maybe (Bool,[HsExportSpec]))+    }+  deriving(Eq,Show)++data HsAssoc = HsAssocNone | HsAssocLeft | HsAssocRight+  deriving(Eq,Show)+  {-! derive: Binary !-}++instance HasLocation HsDecl where+    srcLoc HsTypeDecl	  { hsDeclSrcLoc = sl } = sl+    srcLoc HsTypeFamilyDecl { hsDeclSrcLoc = sl } = sl+    srcLoc HsDeclDeriving { hsDeclSrcLoc = sl } = sl+    srcLoc HsSpaceDecl    { hsDeclSrcLoc = sl } = sl+    srcLoc HsDataDecl	  { hsDeclSrcLoc = sl } = sl+    srcLoc HsInfixDecl    { hsDeclSrcLoc = sl } = sl+    srcLoc HsPragmaSpecialize { hsDeclSrcLoc = sl } = sl+    srcLoc (HsPragmaRules rs) = srcLoc rs+    srcLoc HsForeignDecl  { hsDeclSrcLoc = sl } = sl+    srcLoc HsActionDecl   { hsDeclSrcLoc = sl } = sl+    srcLoc (HsForeignExport sl _ _ _) = sl+    srcLoc (HsClassDecl	 sl _ _) = sl+    srcLoc HsClassAliasDecl { hsDeclSrcLoc = sl } = sl+    srcLoc (HsInstDecl	 sl _ _) = sl+    srcLoc (HsDefaultDecl sl _) = sl+    srcLoc (HsTypeSig	 sl _ _) = sl+    srcLoc (HsFunBind     ms) = srcLoc ms+    srcLoc (HsPatBind	 sl _ _ _) = sl+    srcLoc (HsPragmaProps sl _ _) = sl++instance HasLocation HsRule where+    srcLoc HsRule { hsRuleSrcLoc = sl } = sl++hsDataDecl = HsDataDecl {+    hsDeclDeclType = DeclTypeData,+    hsDeclSrcLoc = bogusASrcLoc,+    hsDeclContext = [],+    hsDeclName = error "hsDataDecl.hsDeclName",+    hsDeclArgs = [],+    hsDeclCons = [],+    hsDeclHasKind = Nothing,+    hsDeclCTYPE = Nothing,+    hsDeclDerives = []+    }++hsNewTypeDecl = hsDataDecl {+    hsDeclDeclType = DeclTypeNewtype,+    hsDeclName = error "hsNewTypeDecl.hsDeclName"+    }++data DeclType = DeclTypeData | DeclTypeNewtype | DeclTypeKind+    deriving(Eq,Show)++data HsDecl+    = HsTypeFamilyDecl {+        hsDeclSrcLoc  :: SrcLoc,+        hsDeclData    :: !Bool,+        hsDeclName    :: HsName,+        hsDeclTArgs   :: [HsType],+        hsDeclHasKind :: Maybe HsKind+        }+    | HsTypeDecl	 {+        hsDeclSrcLoc :: SrcLoc,+        hsDeclName   :: HsName,+        hsDeclTArgs  :: [HsType],+        hsDeclType   :: HsType+        }+    | HsDataDecl	 {+        hsDeclDeclType :: !DeclType,+        hsDeclSrcLoc   :: SrcLoc,+        hsDeclContext  :: HsContext,+        hsDeclName     :: HsName,+        hsDeclArgs     :: [Name],+        hsDeclCons     :: [HsConDecl],+        hsDeclHasKind  :: Maybe HsKind,+        hsDeclCTYPE    :: Maybe String,+        {- deriving -} hsDeclDerives :: [HsName]+        }+    | HsInfixDecl   {+        hsDeclSrcLoc :: SrcLoc,+        hsDeclAssoc  :: HsAssoc,+        hsDeclInt    :: !Int,+        hsDeclNames  :: [HsName]+        }+    | HsClassDecl   {+        hsDeclSrcLoc    :: SrcLoc,+        hsDeclClassHead :: HsClassHead,+        hsDeclDecls     :: [HsDecl]+        }+    | HsClassAliasDecl {+        hsDeclSrcLoc   :: SrcLoc,+        hsDeclName     :: HsName,+        hsDeclTypeArgs :: [HsType],+        {- rhs -} hsDeclContext :: HsContext,+                  hsDeclClasses :: HsContext,+        hsDeclDecls :: [HsDecl]+        }+    | HsInstDecl    {+        hsDeclSrcLoc    :: SrcLoc,+        hsDeclClassHead :: HsClassHead,+        hsDeclDecls     :: [HsDecl]+        }+    | HsDefaultDecl SrcLoc HsType+    | HsTypeSig	 SrcLoc [HsName] HsQualType+    | HsFunBind  [HsMatch]+    | HsPatBind	 SrcLoc HsPat HsRhs {-where-} [HsDecl]+    | HsActionDecl {+        hsDeclSrcLoc   :: SrcLoc,+        hsDeclPat      :: HsPat,+        hsDeclExp      :: HsExp+        }+    | HsSpaceDecl {+        hsDeclSrcLoc   :: SrcLoc,+        hsDeclName     :: HsName,+        hsDeclExp      :: HsExp,+        hsDeclCName    :: Maybe String,+        hsDeclCount    :: Int,+        hsDeclQualType :: HsQualType+        }+    | HsForeignDecl {+        hsDeclSrcLoc   :: SrcLoc,+        hsDeclForeign  :: FfiSpec,+        hsDeclName     :: HsName,+        hsDeclQualType :: HsQualType+        }+    | HsForeignExport {+        hsDeclSrcLoc :: SrcLoc,+        hsDeclFFIExport :: FfiExport,+        hsDeclName :: HsName,+        hsDeclQualType ::HsQualType+        }+    | HsPragmaProps SrcLoc String [HsName]+    | HsPragmaRules [HsRule]+    | HsPragmaSpecialize {+        hsDeclUniq   :: (Module,Int),+        hsDeclSrcLoc :: SrcLoc,+        hsDeclBool   :: Bool,+        hsDeclName   :: HsName,+        hsDeclType   :: HsType+        }+    | HsDeclDeriving {+        hsDeclSrcLoc    :: SrcLoc,+        hsDeclClassHead :: HsClassHead+        }+  deriving(Eq,Show)+  {-! derive: is !-}++data HsRule = HsRule {+    hsRuleUniq      :: (Module,Int),+    hsRuleSrcLoc    :: SrcLoc,+    hsRuleIsMeta    :: Bool,+    hsRuleString    :: String,+    hsRuleFreeVars  :: [(HsName,Maybe HsType)],+    hsRuleLeftExpr  :: HsExp,+    hsRuleRightExpr :: HsExp+    }+  deriving(Eq,Show)++data HsPragmaExp = HsPragmaExp String [HsExp]++instance HasLocation HsMatch where+    srcLoc (HsMatch sl _ _ _ _) = sl++data HsMatch = HsMatch {+    hsMatchSrcLoc :: SrcLoc,+    hsMatchName   :: HsName,+    hsMatchPats   :: [HsPat],+    hsMatchRhs    :: HsRhs,+    {-where-} hsMatchDecls :: [HsDecl]+    }+  deriving(Eq,Show)++data HsConDecl+    = HsConDecl {+        hsConDeclSrcLoc :: SrcLoc,+        hsConDeclExists :: [HsTyVarBind],+        hsConDeclName   :: HsName,+        hsConDeclConArg :: [HsBangType]+        }+    | HsRecDecl {+        hsConDeclSrcLoc :: SrcLoc,+        hsConDeclExists :: [HsTyVarBind],+        hsConDeclName   :: HsName,+        hsConDeclRecArg :: [([HsName],HsBangType)]+        }+  deriving(Eq,Show)+  {-! derive: is, update !-}++hsConDeclArgs HsConDecl { hsConDeclConArg = as } = as+hsConDeclArgs HsRecDecl { hsConDeclRecArg = as } = concat [ replicate (length ns) t | (ns,t) <- as]++data HsBangType+	 = HsBangedTy   { hsBangType :: HsType }+	 | HsUnBangedTy { hsBangType :: HsType }+  deriving(Eq,Show)++data HsRhs+	 = HsUnGuardedRhs HsExp+	 | HsGuardedRhss  [HsGuardedRhs]+  deriving(Eq,Show)++data HsGuardedRhs = HsGuardedRhs SrcLoc HsExp HsExp+  deriving(Eq,Show)++data HsQualType = HsQualType {+    hsQualTypeContext :: HsContext,+    hsQualTypeType :: HsType+    } deriving(Data,Typeable,Eq,Ord,Show)+  {-! derive: Binary !-}++type LHsType = Located HsType++data HsType+    = HsTyFun HsType HsType+    | HsTyTuple [HsType]+    | HsTyUnboxedTuple [HsType]+    | HsTyApp HsType HsType+    | HsTyVar { hsTypeName :: HsName }+    | HsTyCon { hsTypeName :: HsName }+    | HsTyForall {+       hsTypeVars :: [HsTyVarBind],+       hsTypeType :: HsQualType }+    | HsTyExists {+       hsTypeVars :: [HsTyVarBind],+       hsTypeType :: HsQualType }+    | HsTyExpKind {+        hsTyLType :: LHsType,+        hsTyKind :: HsKind }+    | HsTyStrictType {+        hsTyStrict :: !Bool,+        hsTyLType :: LHsType+    }+    -- the following is used internally+    | HsTyAssoc+    | HsTyEq HsType HsType+  deriving(Data,Typeable,Eq,Ord,Show)+  {-! derive: Binary, is !-}++data HsTyVarBind = HsTyVarBind {+    hsTyVarBindSrcLoc :: SrcLoc,+    hsTyVarBindName :: HsName,+    hsTyVarBindKind :: Maybe HsKind }+  deriving(Data,Typeable,Eq,Ord,Show)+  {-! derive: Binary, update !-}++hsTyVarBind = HsTyVarBind {+    hsTyVarBindSrcLoc = bogusASrcLoc,+    hsTyVarBindName = undefined,+    hsTyVarBindKind = Nothing+    }++instance HasLocation HsTyVarBind where+    srcLoc = hsTyVarBindSrcLoc++type HsContext = [HsAsst]++data HsAsst = HsAsst HsName [HsName] | HsAsstEq HsType HsType+  deriving(Data,Typeable,Eq,Ord, Show)+    {-! derive: Binary !-}++data HsLiteral+	= HsInt		!Integer+	| HsChar	!Char+	| HsString	String+	| HsFrac	Rational+	-- GHC unboxed literals:+	| HsCharPrim	Char+	| HsStringPrim	String+	| HsIntPrim	Integer+	| HsFloatPrim	Rational+	| HsDoublePrim	Rational+	-- GHC extension:+	| HsLitLit	String+  deriving(Eq,Ord, Show)+    {-! derive: is !-}++hsParen x@HsVar {} = x+hsParen x@HsCon {} = x+hsParen x@HsParen {} = x+hsParen x@HsLit {} = x+hsParen x@HsTuple {} = x+hsParen x@HsUnboxedTuple {} = x+hsParen x = HsParen x++data HsErrorType+    = HsErrorPatternFailure+    | HsErrorSource+    | HsErrorFieldSelect+    | HsErrorUnderscore+    | HsErrorUninitializedField+    | HsErrorRecordUpdate+ deriving(Eq,Show)++type LHsExp = Located HsExp++data HsExp+	= HsVar { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName }+	| HsCon { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName }+	| HsLit HsLiteral+	| HsInfixApp HsExp HsExp HsExp+	| HsApp HsExp HsExp+	| HsNegApp HsExp+	| HsLambda SrcLoc [HsPat] HsExp+	| HsLet [HsDecl] HsExp+	| HsIf HsExp HsExp HsExp+	| HsCase HsExp [HsAlt]+	| HsDo { hsExpStatements :: [HsStmt] }+	| HsTuple [HsExp]+	| HsUnboxedTuple [HsExp]+	| HsList [HsExp]+	| HsParen HsExp+	| HsLeftSection HsExp HsExp+	| HsRightSection HsExp HsExp+	| HsRecConstr HsName [HsFieldUpdate]+	| HsRecUpdate HsExp [HsFieldUpdate]+	| HsEnumFrom HsExp+	| HsEnumFromTo HsExp HsExp+	| HsEnumFromThen HsExp HsExp+	| HsEnumFromThenTo HsExp HsExp HsExp+	| HsListComp HsExp [HsStmt]+	| HsExpTypeSig SrcLoc HsExp HsQualType+	| HsAsPat { hsExpName :: HsName, hsExpExp :: HsExp }+        | HsError { hsExpSrcLoc :: SrcLoc, hsExpErrorType :: HsErrorType, hsExpString :: String }+	| HsWildCard SrcLoc+	| HsIrrPat { hsExpLExp :: LHsExp }+	| HsBangPat { hsExpLExp :: LHsExp }+        | HsLocatedExp LHsExp+ deriving(Eq,Show)+    {-! derive: is, update !-}++data HsClassHead = HsClassHead {+    hsClassHeadContext :: HsContext,+    hsClassHead :: HsName,+    hsClassHeadArgs :: [HsType] }+ deriving(Eq,Show)+    {-! derive: update !-}++type LHsPat = Located HsPat++data HsPat+	= HsPVar { hsPatName :: HsName }+	| HsPLit { hsPatLit :: HsLiteral }+	| HsPNeg HsPat+	| HsPInfixApp HsPat HsName HsPat+	| HsPApp { hsPatName :: HsName, hsPatPats :: [HsPat] }+	| HsPTuple [HsPat]+	| HsPUnboxedTuple [HsPat]+	| HsPList [HsPat]+	| HsPParen HsPat+	| HsPRec HsName [HsPatField]+	| HsPAsPat { hsPatName :: HsName, hsPatPat :: HsPat }+	| HsPWildCard+	| HsPIrrPat { hsPatLPat :: LHsPat }+	| HsPBangPat { hsPatLPat :: LHsPat }+	| HsPTypeSig SrcLoc HsPat HsQualType  -- scoped type variable extension+ deriving(Eq,Ord,Show)+ {-! derive: is !-}++data HsPatField = HsPFieldPat HsName HsPat+    deriving(Eq,Ord,Show)++data HsStmt+	= HsGenerator SrcLoc HsPat HsExp       -- srcloc added by bernie+	| HsQualifier HsExp+	| HsLetStmt [HsDecl]+ deriving(Eq,Show)++data HsFieldUpdate = HsFieldUpdate HsName HsExp+  deriving(Eq,Show)++data HsAlt = HsAlt SrcLoc HsPat HsRhs [HsDecl]+  deriving(Eq,Show)++data HsKind = HsKind HsName | HsKindFn HsKind HsKind+  deriving(Data,Typeable,Eq,Ord,Show)+  {-! derive: Binary !-}++hsKindStar = HsKind s_Star+hsKindHash = HsKind s_Hash+hsKindBang = HsKind s_Bang+hsKindQuest = HsKind s_Quest+hsKindQuestQuest = HsKind s_QuestQuest+hsKindStarBang = HsKind s_StarBang+{-* Generated by DrIFT : Look, but Don't Touch. *-}+hsModuleDecls_u f r@HsModule{hsModuleDecls  = x} = r{hsModuleDecls = f x}+hsModuleExports_u f r@HsModule{hsModuleExports  = x} = r{hsModuleExports = f x}+hsModuleImports_u f r@HsModule{hsModuleImports  = x} = r{hsModuleImports = f x}+hsModuleName_u f r@HsModule{hsModuleName  = x} = r{hsModuleName = f x}+hsModuleOpt_u f r@HsModule{hsModuleOpt  = x} = r{hsModuleOpt = f x}+hsModuleOptions_u f r@HsModule{hsModuleOptions  = x} = r{hsModuleOptions = f x}+hsModuleSrcLoc_u f r@HsModule{hsModuleSrcLoc  = x} = r{hsModuleSrcLoc = f x}+hsModuleDecls_s v =  hsModuleDecls_u  (const v)+hsModuleExports_s v =  hsModuleExports_u  (const v)+hsModuleImports_s v =  hsModuleImports_u  (const v)+hsModuleName_s v =  hsModuleName_u  (const v)+hsModuleOpt_s v =  hsModuleOpt_u  (const v)+hsModuleOptions_s v =  hsModuleOptions_u  (const v)+hsModuleSrcLoc_s v =  hsModuleSrcLoc_u  (const v)++instance Data.Binary.Binary HsAssoc where+    put HsAssocNone = do+	    Data.Binary.putWord8 0+    put HsAssocLeft = do+	    Data.Binary.putWord8 1+    put HsAssocRight = do+	    Data.Binary.putWord8 2+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return HsAssocNone+	      1 -> do+		    return HsAssocLeft+	      2 -> do+		    return HsAssocRight+	      _ -> fail "invalid binary data found"++isHsTypeFamilyDecl (HsTypeFamilyDecl _ _ _ _ _) = True+isHsTypeFamilyDecl _ = False+isHsTypeDecl (HsTypeDecl _ _ _ _) = True+isHsTypeDecl _ = False+isHsDataDecl (HsDataDecl _ _ _ _ _ _ _ _ _) = True+isHsDataDecl _ = False+isHsInfixDecl (HsInfixDecl _ _ _ _) = True+isHsInfixDecl _ = False+isHsClassDecl (HsClassDecl _ _ _) = True+isHsClassDecl _ = False+isHsClassAliasDecl (HsClassAliasDecl _ _ _ _ _ _) = True+isHsClassAliasDecl _ = False+isHsInstDecl (HsInstDecl _ _ _) = True+isHsInstDecl _ = False+isHsDefaultDecl (HsDefaultDecl _ _) = True+isHsDefaultDecl _ = False+isHsTypeSig (HsTypeSig _ _ _) = True+isHsTypeSig _ = False+isHsFunBind (HsFunBind _) = True+isHsFunBind _ = False+isHsPatBind (HsPatBind _ _ _ _) = True+isHsPatBind _ = False+isHsActionDecl (HsActionDecl _ _ _) = True+isHsActionDecl _ = False+isHsSpaceDecl (HsSpaceDecl _ _ _ _ _ _) = True+isHsSpaceDecl _ = False+isHsForeignDecl (HsForeignDecl _ _ _ _) = True+isHsForeignDecl _ = False+isHsForeignExport (HsForeignExport _ _ _ _) = True+isHsForeignExport _ = False+isHsPragmaProps (HsPragmaProps _ _ _) = True+isHsPragmaProps _ = False+isHsPragmaRules (HsPragmaRules _) = True+isHsPragmaRules _ = False+isHsPragmaSpecialize (HsPragmaSpecialize _ _ _ _ _) = True+isHsPragmaSpecialize _ = False+isHsDeclDeriving (HsDeclDeriving _ _) = True+isHsDeclDeriving _ = False++isHsConDecl (HsConDecl _ _ _ _) = True+isHsConDecl _ = False+isHsRecDecl (HsRecDecl _ _ _ _) = True+isHsRecDecl _ = False++hsConDeclConArg_u f r@HsConDecl{hsConDeclConArg  = x} = r{hsConDeclConArg = f x}+hsConDeclConArg_u _ x = x+hsConDeclExists_u f r@HsConDecl{hsConDeclExists  = x} = r{hsConDeclExists = f x}+hsConDeclExists_u f r@HsRecDecl{hsConDeclExists  = x} = r{hsConDeclExists = f x}+hsConDeclName_u f r@HsConDecl{hsConDeclName  = x} = r{hsConDeclName = f x}+hsConDeclName_u f r@HsRecDecl{hsConDeclName  = x} = r{hsConDeclName = f x}+hsConDeclRecArg_u f r@HsRecDecl{hsConDeclRecArg  = x} = r{hsConDeclRecArg = f x}+hsConDeclRecArg_u _ x = x+hsConDeclSrcLoc_u f r@HsConDecl{hsConDeclSrcLoc  = x} = r{hsConDeclSrcLoc = f x}+hsConDeclSrcLoc_u f r@HsRecDecl{hsConDeclSrcLoc  = x} = r{hsConDeclSrcLoc = f x}+hsConDeclConArg_s v =  hsConDeclConArg_u  (const v)+hsConDeclExists_s v =  hsConDeclExists_u  (const v)+hsConDeclName_s v =  hsConDeclName_u  (const v)+hsConDeclRecArg_s v =  hsConDeclRecArg_u  (const v)+hsConDeclSrcLoc_s v =  hsConDeclSrcLoc_u  (const v)++instance Data.Binary.Binary HsQualType where+    put (HsQualType aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (HsQualType aa ab)++instance Data.Binary.Binary HsType where+    put (HsTyFun aa ab) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+    put (HsTyTuple ac) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ac+    put (HsTyUnboxedTuple ad) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ad+    put (HsTyApp ae af) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ae+	    Data.Binary.put af+    put (HsTyVar ag) = do+	    Data.Binary.putWord8 4+	    Data.Binary.put ag+    put (HsTyCon ah) = do+	    Data.Binary.putWord8 5+	    Data.Binary.put ah+    put (HsTyForall ai aj) = do+	    Data.Binary.putWord8 6+	    Data.Binary.put ai+	    Data.Binary.put aj+    put (HsTyExists ak al) = do+	    Data.Binary.putWord8 7+	    Data.Binary.put ak+	    Data.Binary.put al+    put (HsTyExpKind am an) = do+	    Data.Binary.putWord8 8+	    Data.Binary.put am+	    Data.Binary.put an+    put (HsTyStrictType ao ap) = do+	    Data.Binary.putWord8 9+	    Data.Binary.put ao+	    Data.Binary.put ap+    put HsTyAssoc = do+	    Data.Binary.putWord8 10+    put (HsTyEq aq ar) = do+	    Data.Binary.putWord8 11+	    Data.Binary.put aq+	    Data.Binary.put ar+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    return (HsTyFun aa ab)+	      1 -> do+		    ac <- Data.Binary.get+		    return (HsTyTuple ac)+	      2 -> do+		    ad <- Data.Binary.get+		    return (HsTyUnboxedTuple ad)+	      3 -> do+		    ae <- Data.Binary.get+		    af <- Data.Binary.get+		    return (HsTyApp ae af)+	      4 -> do+		    ag <- Data.Binary.get+		    return (HsTyVar ag)+	      5 -> do+		    ah <- Data.Binary.get+		    return (HsTyCon ah)+	      6 -> do+		    ai <- Data.Binary.get+		    aj <- Data.Binary.get+		    return (HsTyForall ai aj)+	      7 -> do+		    ak <- Data.Binary.get+		    al <- Data.Binary.get+		    return (HsTyExists ak al)+	      8 -> do+		    am <- Data.Binary.get+		    an <- Data.Binary.get+		    return (HsTyExpKind am an)+	      9 -> do+		    ao <- Data.Binary.get+		    ap <- Data.Binary.get+		    return (HsTyStrictType ao ap)+	      10 -> do+		    return HsTyAssoc+	      11 -> do+		    aq <- Data.Binary.get+		    ar <- Data.Binary.get+		    return (HsTyEq aq ar)+	      _ -> fail "invalid binary data found"++isHsTyFun (HsTyFun _ _) = True+isHsTyFun _ = False+isHsTyTuple (HsTyTuple _) = True+isHsTyTuple _ = False+isHsTyUnboxedTuple (HsTyUnboxedTuple _) = True+isHsTyUnboxedTuple _ = False+isHsTyApp (HsTyApp _ _) = True+isHsTyApp _ = False+isHsTyVar (HsTyVar _) = True+isHsTyVar _ = False+isHsTyCon (HsTyCon _) = True+isHsTyCon _ = False+isHsTyForall (HsTyForall _ _) = True+isHsTyForall _ = False+isHsTyExists (HsTyExists _ _) = True+isHsTyExists _ = False+isHsTyExpKind (HsTyExpKind _ _) = True+isHsTyExpKind _ = False+isHsTyStrictType (HsTyStrictType _ _) = True+isHsTyStrictType _ = False+isHsTyAssoc (HsTyAssoc) = True+isHsTyAssoc _ = False+isHsTyEq (HsTyEq _ _) = True+isHsTyEq _ = False++instance Data.Binary.Binary HsTyVarBind where+    put (HsTyVarBind aa ab ac) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+    get = do+    aa <- get+    ab <- get+    ac <- get+    return (HsTyVarBind aa ab ac)++hsTyVarBindKind_u f r@HsTyVarBind{hsTyVarBindKind  = x} = r{hsTyVarBindKind = f x}+hsTyVarBindName_u f r@HsTyVarBind{hsTyVarBindName  = x} = r{hsTyVarBindName = f x}+hsTyVarBindSrcLoc_u f r@HsTyVarBind{hsTyVarBindSrcLoc  = x} = r{hsTyVarBindSrcLoc = f x}+hsTyVarBindKind_s v =  hsTyVarBindKind_u  (const v)+hsTyVarBindName_s v =  hsTyVarBindName_u  (const v)+hsTyVarBindSrcLoc_s v =  hsTyVarBindSrcLoc_u  (const v)++instance Data.Binary.Binary HsAsst where+    put (HsAsst aa ab) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+    put (HsAsstEq ac ad) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    return (HsAsst aa ab)+	      1 -> do+		    ac <- Data.Binary.get+		    ad <- Data.Binary.get+		    return (HsAsstEq ac ad)+	      _ -> fail "invalid binary data found"++isHsInt (HsInt _) = True+isHsInt _ = False+isHsChar (HsChar _) = True+isHsChar _ = False+isHsString (HsString _) = True+isHsString _ = False+isHsFrac (HsFrac _) = True+isHsFrac _ = False+isHsCharPrim (HsCharPrim _) = True+isHsCharPrim _ = False+isHsStringPrim (HsStringPrim _) = True+isHsStringPrim _ = False+isHsIntPrim (HsIntPrim _) = True+isHsIntPrim _ = False+isHsFloatPrim (HsFloatPrim _) = True+isHsFloatPrim _ = False+isHsDoublePrim (HsDoublePrim _) = True+isHsDoublePrim _ = False+isHsLitLit (HsLitLit _) = True+isHsLitLit _ = False++isHsVar (HsVar _) = True+isHsVar _ = False+isHsCon (HsCon _) = True+isHsCon _ = False+isHsLit (HsLit _) = True+isHsLit _ = False+isHsInfixApp (HsInfixApp _ _ _) = True+isHsInfixApp _ = False+isHsApp (HsApp _ _) = True+isHsApp _ = False+isHsNegApp (HsNegApp _) = True+isHsNegApp _ = False+isHsLambda (HsLambda _ _ _) = True+isHsLambda _ = False+isHsLet (HsLet _ _) = True+isHsLet _ = False+isHsIf (HsIf _ _ _) = True+isHsIf _ = False+isHsCase (HsCase _ _) = True+isHsCase _ = False+isHsDo (HsDo _) = True+isHsDo _ = False+isHsTuple (HsTuple _) = True+isHsTuple _ = False+isHsUnboxedTuple (HsUnboxedTuple _) = True+isHsUnboxedTuple _ = False+isHsList (HsList _) = True+isHsList _ = False+isHsParen (HsParen _) = True+isHsParen _ = False+isHsLeftSection (HsLeftSection _ _) = True+isHsLeftSection _ = False+isHsRightSection (HsRightSection _ _) = True+isHsRightSection _ = False+isHsRecConstr (HsRecConstr _ _) = True+isHsRecConstr _ = False+isHsRecUpdate (HsRecUpdate _ _) = True+isHsRecUpdate _ = False+isHsEnumFrom (HsEnumFrom _) = True+isHsEnumFrom _ = False+isHsEnumFromTo (HsEnumFromTo _ _) = True+isHsEnumFromTo _ = False+isHsEnumFromThen (HsEnumFromThen _ _) = True+isHsEnumFromThen _ = False+isHsEnumFromThenTo (HsEnumFromThenTo _ _ _) = True+isHsEnumFromThenTo _ = False+isHsListComp (HsListComp _ _) = True+isHsListComp _ = False+isHsExpTypeSig (HsExpTypeSig _ _ _) = True+isHsExpTypeSig _ = False+isHsAsPat (HsAsPat _ _) = True+isHsAsPat _ = False+isHsError (HsError _ _ _) = True+isHsError _ = False+isHsWildCard (HsWildCard _) = True+isHsWildCard _ = False+isHsIrrPat (HsIrrPat _) = True+isHsIrrPat _ = False+isHsBangPat (HsBangPat _) = True+isHsBangPat _ = False+isHsLocatedExp (HsLocatedExp _) = True+isHsLocatedExp _ = False++hsExpErrorType_u f r@HsError{hsExpErrorType  = x} = r{hsExpErrorType = f x}+hsExpErrorType_u _ x = x+hsExpExp_u f r@HsAsPat{hsExpExp  = x} = r{hsExpExp = f x}+hsExpExp_u _ x = x+hsExpLExp_u f r@HsBangPat{hsExpLExp  = x} = r{hsExpLExp = f x}+hsExpLExp_u f r@HsIrrPat{hsExpLExp  = x} = r{hsExpLExp = f x}+hsExpLExp_u _ x = x+hsExpName_u f r@HsAsPat{hsExpName  = x} = r{hsExpName = f x}+hsExpName_u f r@HsCon{hsExpName  = x} = r{hsExpName = f x}+hsExpName_u f r@HsVar{hsExpName  = x} = r{hsExpName = f x}+hsExpName_u _ x = x+hsExpSrcLoc_u f r@HsError{hsExpSrcLoc  = x} = r{hsExpSrcLoc = f x}+hsExpSrcLoc_u _ x = x+hsExpStatements_u f r@HsDo{hsExpStatements  = x} = r{hsExpStatements = f x}+hsExpStatements_u _ x = x+hsExpString_u f r@HsError{hsExpString  = x} = r{hsExpString = f x}+hsExpString_u _ x = x+hsExpErrorType_s v =  hsExpErrorType_u  (const v)+hsExpExp_s v =  hsExpExp_u  (const v)+hsExpLExp_s v =  hsExpLExp_u  (const v)+hsExpName_s v =  hsExpName_u  (const v)+hsExpSrcLoc_s v =  hsExpSrcLoc_u  (const v)+hsExpStatements_s v =  hsExpStatements_u  (const v)+hsExpString_s v =  hsExpString_u  (const v)++hsClassHead_u f r@HsClassHead{hsClassHead  = x} = r{hsClassHead = f x}+hsClassHeadArgs_u f r@HsClassHead{hsClassHeadArgs  = x} = r{hsClassHeadArgs = f x}+hsClassHeadContext_u f r@HsClassHead{hsClassHeadContext  = x} = r{hsClassHeadContext = f x}+hsClassHead_s v =  hsClassHead_u  (const v)+hsClassHeadArgs_s v =  hsClassHeadArgs_u  (const v)+hsClassHeadContext_s v =  hsClassHeadContext_u  (const v)++isHsPVar (HsPVar _) = True+isHsPVar _ = False+isHsPLit (HsPLit _) = True+isHsPLit _ = False+isHsPNeg (HsPNeg _) = True+isHsPNeg _ = False+isHsPInfixApp (HsPInfixApp _ _ _) = True+isHsPInfixApp _ = False+isHsPApp (HsPApp _ _) = True+isHsPApp _ = False+isHsPTuple (HsPTuple _) = True+isHsPTuple _ = False+isHsPUnboxedTuple (HsPUnboxedTuple _) = True+isHsPUnboxedTuple _ = False+isHsPList (HsPList _) = True+isHsPList _ = False+isHsPParen (HsPParen _) = True+isHsPParen _ = False+isHsPRec (HsPRec _ _) = True+isHsPRec _ = False+isHsPAsPat (HsPAsPat _ _) = True+isHsPAsPat _ = False+isHsPWildCard (HsPWildCard) = True+isHsPWildCard _ = False+isHsPIrrPat (HsPIrrPat _) = True+isHsPIrrPat _ = False+isHsPBangPat (HsPBangPat _) = True+isHsPBangPat _ = False+isHsPTypeSig (HsPTypeSig _ _ _) = True+isHsPTypeSig _ = False++instance Data.Binary.Binary HsKind where+    put (HsKind aa) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+    put (HsKindFn ab ac) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ab+	    Data.Binary.put ac+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    return (HsKind aa)+	      1 -> do+		    ab <- Data.Binary.get+		    ac <- Data.Binary.get+		    return (HsKindFn ab ac)+	      _ -> fail "invalid binary data found"++--  Imported from other files :-
+ drift_processed/FrontEnd/KindInfer.hs view
@@ -0,0 +1,633 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/KindInfer.hs" #-}+{-# OPTIONS -funbox-strict-fields #-}+-- |+-- This module implements the Kind Inference algorithm, and the routines which+-- use the product of kind inference to convert haskell source types into the+-- simplified kind annotated types used by the rest of the FrontEnd.++module FrontEnd.KindInfer (+    kiDecls,+    KindEnv(),+    hsQualTypeToSigma,+    hsAsstToPred,+    kiHsQualType,+    kindOfClass,+    kindOf,+    restrictKindEnv,+    hsTypeToType,+    getConstructorKinds+    ) where++import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Binary+import Data.Generics(Typeable, everything, mkQ)+import Data.IORef+import Data.List+import System.IO.Unsafe+import Util.Inst()+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Traversable as T++import Doc.DocLike+import Doc.PPrint+import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import FrontEnd.Tc.Kind+import FrontEnd.Tc.Type+import FrontEnd.Utils+import FrontEnd.Warning+import Name.Name+import Options+import Support.FreeVars+import Support.MapBinaryInstance+import Util.ContextMonad+import Util.HasSize+import qualified FlagDump as FD+import qualified Util.Seq as Seq++data KindEnv = KindEnv {+    kindEnv :: Map.Map Name Kind,+    kindEnvAssocs :: Map.Map Name (Int,Int),+    kindEnvClasses :: Map.Map Name [Kind]+    } deriving(Typeable,Show)+        {-!derive: Monoid !-}++instance Binary KindEnv where+    put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } =+        putMap a >> putMap b >> putMap c+    get = do+        a <- getMap+        b <- getMap+        c <- getMap+        return KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c }++instance HasSize KindEnv where+    size KindEnv { kindEnv = env } = size env++instance FreeVars Kind (Set.Set Kindvar) where+   freeVars (KVar kindvar) = Set.singleton kindvar+   freeVars (kind1 `Kfun` kind2) = freeVars kind1 `Set.union` freeVars kind2+   freeVars KBase {} = mempty++instance DocLike d =>  PPrint d KindEnv where+    pprint KindEnv { kindEnv = m, kindEnvAssocs = ev, kindEnvClasses = cs } = vcat $+        [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m] +++        [ text "associated type" <+> pprint n <+> pprint ab  | (n,ab) <- Map.toList ev] +++        [ text "class" <+> pprint n <+> pprint ab  | (n,ab) <- Map.toList cs] +++        [empty]++--------------------------------------------------------------------------------++-- The kind inference monad++data KiWhere = InClass | InInstance | Other+    deriving(Eq)++data KiEnv  = KiEnv {+    kiSrcLoc  :: SrcLoc,+    kiContext :: [String],+    kiEnv     :: !(IORef KindEnv),+    kiWhere   :: !KiWhere,+    kiVarnum  :: !(IORef Int)+    }++newtype Ki a = Ki (ReaderT KiEnv IO a)+    deriving(Monad,MonadReader KiEnv,MonadIO,Functor,MonadWarn)++instance MonadSrcLoc Ki where+    getSrcLoc = asks kiSrcLoc+instance MonadSetSrcLoc Ki where+    withSrcLoc sl = local (\s -> s { kiSrcLoc = sl })++restrictKindEnv :: (Name -> Bool) -> KindEnv -> KindEnv+restrictKindEnv f ke = ke { kindEnv = Map.filterWithKey (\k _ -> f k) (kindEnv ke) }++findKind :: MonadIO m => Kind -> m Kind+findKind tv@(KVar Kindvar {kvarRef = r, kvarConstraint = con }) = liftIO $ do+    rt <- readIORef r+    case rt of+        Nothing+            | con == KindStar -> writeIORef r (Just kindStar) >> return kindStar+            | otherwise -> return tv+        Just t -> do+            t' <- findKind t+            writeIORef r (Just t')+            return t'+findKind tv = return tv++-- useful operations in the inference monad++runKI :: KindEnv -> Ki a -> IO a+runKI env (Ki ki) = (kienv >>= ki') where+    kienv = do+        env <- newIORef env+        varnum <- newIORef 0+        return KiEnv {+            kiSrcLoc = bogusASrcLoc,+            kiContext = [],+            kiEnv = env,+            kiVarnum = varnum,+            kiWhere = Other }+    ki' e = runReaderT ki e++instance ContextMonad Ki where+    type ContextOf Ki = String+    withContext nc x = local (\s -> s { kiContext = nc :kiContext s }) x++getEnv :: Ki KindEnv+getEnv = do asks kiEnv >>= liftIO . readIORef++unify :: Kind -> Kind -> Ki ()+unify k1 k2 = do+    k1 <- flattenKind k1+    k2 <- flattenKind k2+    printRule $ "unify:" <+> pprint k1 <+> text "<->" <+> pprint k2+    mgu k1 k2++mgu :: Kind -> Kind -> Ki ()+mgu (KBase a) (KBase b) | a == b = return ()+mgu (Kfun a b) (Kfun a' b') = do+    unify a a'+    unify b b'+mgu (KVar u) k = varBind u k+mgu k (KVar u) = varBind u k+mgu k1 k2 = addWarn UnificationError $+    "kind unification error, attempt to unify (" ++ show k1 ++ ") with (" ++ show k2 ++ ")"++varBind :: Kindvar -> Kind -> Ki ()+varBind u k = do+    k <- flattenKind k+    printRule $ "varBind:" <+> pprint u <+> text ":=" <+> pprint k+    if k == KVar u then return () else do+    when (u `Set.member` freeVars k) $ addWarn OccursCheck $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k+    v <- liftIO $ readIORef (kvarRef u)+    case v of+        Just v -> fail $ "varBind unfree"+        Nothing -> do+            liftIO $ writeIORef (kvarRef u) (Just k)+            constrain (kvarConstraint u) k++zonkConstraint :: KindConstraint -> Kindvar -> Ki ()+zonkConstraint nk mv = do+    let fk = mappend nk (kvarConstraint mv)+    if fk == kvarConstraint mv then return () else do+        nref <- liftIO $ newIORef Nothing+        let nmv = mv { kvarConstraint = fk, kvarRef = nref }+        liftIO $ modifyIORef (kvarRef mv) (\Nothing -> Just $ KVar nmv)++constrain KindAny k = return ()+constrain KindStar        (KBase Star) = return ()+constrain KindQuest       k@KBase {}  = kindCombine kindFunRet k >> return ()+constrain KindQuestQuest  (KBase KQuest) = fail "cannot constrain ? to be ??"+constrain KindQuestQuest  k@KBase {}  = kindCombine kindArg k >> return ()+constrain KindSimple (KBase Star) = return ()+constrain KindSimple (a `Kfun` b) = do+    a <- findKind a+    b <- findKind b+    constrain KindSimple a+    constrain KindSimple b+constrain con (KVar v) = zonkConstraint con v+constrain con k = fail $ "constraining kind: " ++ show (con,k)++flattenKind :: Kind -> Ki Kind+flattenKind k = f' k where+    f (a `Kfun` b) = return Kfun `ap` f' a `ap` f' b+    f k = return k+    f' k = findKind k >>= f++newKindVar :: KindConstraint -> Ki Kindvar+newKindVar con = do+    KiEnv { kiVarnum = vr } <- ask+    liftIO $ do+    n <- readIORef vr+    writeIORef vr $! (n + 1)+    nr <- newIORef Nothing+    return Kindvar { kvarUniq = n, kvarRef = nr, kvarConstraint = con }++lookupKind :: KindConstraint -> Name -> Ki Kind+lookupKind con name = do+    KindEnv { kindEnv = env } <- getEnv+    case Map.lookup name env of+        Just k -> do+            k <- f k+            k <- findKind k+            constrain con k+            findKind k+        Nothing -> do+            kv <- newKindVar con+            extendEnv mempty { kindEnv = Map.singleton name (KVar kv) }+            return (KVar kv)+    where+      -- ?? and ? aren't *really* kinds+      f (KBase KQuestQuest) = liftM KVar $ newKindVar KindQuestQuest+      f (KBase KQuest)      = liftM KVar $ newKindVar KindQuest+      f k@(KBase _)         = return k+      f (Kfun k1 k2)        = liftM2 Kfun (f k1) (f k2)+      f k@(KVar _)          = return k++extendEnv :: KindEnv -> Ki ()+extendEnv newEnv = do+    ref <- asks kiEnv+    liftIO $ modifyIORef ref (mappend newEnv) -- (\ (KindEnv env x) -> KindEnv (env `Map.union` newEnv) (nx `mappend` x))++getConstructorKinds :: KindEnv -> Map.Map Name Kind+getConstructorKinds ke = kindEnv ke -- Map.fromList [ (toName TypeConstructor x,y) | (x,y)<- Map.toList m]++--------------------------------------------------------------------------------++-- kind inference proper+-- this is what gets called from outside of this module++printRule :: String -> Ki ()+printRule s+    | dump FD.KindSteps = liftIO $ putStrLn s+    | otherwise = return ()++{-# NOINLINE kiDecls #-}+kiDecls :: KindEnv -> [HsDecl] -> IO KindEnv+kiDecls inputEnv classAndDataDecls = ans where+    ans = do+        ke <- run+        return ke -- TODO (Map.fromList (concatMap kgAssocs kindGroups) `mappend` as))+    run = runKI inputEnv $ withContext ("kiDecls: " ++ show (map getDeclName classAndDataDecls)) $ do+        kiInitClasses classAndDataDecls+        mapM_ kiDecl classAndDataDecls+        getEnv >>= postProcess++postProcess ke = do+    kindEnv <- T.mapM flattenKind (kindEnv ke)+    kindEnvClasses <- T.mapM (mapM flattenKind) (kindEnvClasses ke)+    let defs = Set.toList (freeVars (Map.elems kindEnv,Map.elems kindEnvClasses))+    printRule $ "defaulting the following kinds: " ++ pprint defs+    mapM_ (flip varBind kindStar) defs+    kindEnv <- T.mapM flattenKind kindEnv+    kindEnvClasses <- T.mapM (mapM flattenKind) kindEnvClasses+    return ke { kindEnvClasses = kindEnvClasses, kindEnv = kindEnv }++kiType,kiType' :: Kind -> HsType -> Ki ()+kiType' k t = do+    k <- findKind k+    kiType k t++kiType k (HsTyTuple ts) = do+    unify kindStar k+    mapM_ (kiType' kindStar) ts+kiType k (HsTyUnboxedTuple ts) = do+    unify kindUTuple k+    flip mapM_ ts $ \t -> do+        kt <- newKindVar KindQuestQuest+        kiType (KVar kt) t+kiType k (HsTyFun a b) = do+    unify kindStar k+    ka <- newKindVar KindQuestQuest+    kb <- newKindVar KindQuest+    kiType (KVar ka) a+    kiType (KVar kb) b+kiType k (HsTyApp a b) = do+    kv <- newKindVar KindAny+    kiType  (KVar kv `Kfun` k) a+    kiType' (KVar kv) b+kiType k (HsTyVar v) = do+    kv <- lookupKind KindAny (toName TypeVal v)+    unify k kv+kiType k (HsTyCon v) = do+    kv <- lookupKind KindAny (toName TypeConstructor v)+    unify k kv+kiType k HsTyAssoc = do+    constrain KindSimple k+kiType _ HsTyEq {} = error "kiType.HsTyEq"+kiType k HsTyForall { hsTypeVars = vs, hsTypeType = HsQualType con t } = do+    mapM_ initTyVarBind vs+    mapM_ kiPred con+    kiType' k t+kiType k HsTyExpKind { hsTyLType = Located _ t, hsTyKind = ek } = do+    unify (hsKindToKind ek) k+    kiType' k t+kiType k HsTyExists { hsTypeVars = vs, hsTypeType = HsQualType con t } = do+    mapM_ initTyVarBind vs+    mapM_ kiPred con+    kiType' k t+kiType _ _ = error "KindInfer.kiType: bad."++initTyVarBind HsTyVarBind { hsTyVarBindName = name, hsTyVarBindKind = kk } = do+    nk <- lookupKind KindSimple (toName TypeVal name)+    case kk of+        Nothing -> return ()+        Just kk -> unify nk (hsKindToKind kk)++hsKindToKind (HsKindFn a b) = hsKindToKind a `Kfun` hsKindToKind b+hsKindToKind a | a == hsKindStar       = kindStar+               | a == hsKindHash       = kindHash+               | a == hsKindQuest      = kindFunRet+               | a == hsKindQuestQuest = kindArg+hsKindToKind (HsKind n) = KBase (KNamed (toName SortName n))+-- hsKindToKind (HsKind n) = toName SortName n++kiApps :: Kind -> [HsType] -> Kind -> Ki ()+kiApps ca args fk = f ca args fk where+    f ca [] fk = unify ca fk+    f (x `Kfun` y) (a:as) fk = do+        kiType' x a+        y <- findKind y+        f y as fk+    f (KVar var) as fk = do+        x <- newKindVar KindAny+        y <- newKindVar KindAny+        let nv = (KVar x `Kfun` KVar y)+        varBind var nv+        f nv as fk+    f _ _ _ = error "KindInfer.kiApps: bad."++kiApps' :: Kind -> [Kind] -> Kind -> Ki ()+kiApps' ca args fk = f ca args fk where+    f ca [] fk = unify ca fk+    f (x `Kfun` y) (a:as) fk = do+        unify a x+        y <- findKind y+        f y as fk+    f (KVar var) as fk = do+        x <- newKindVar KindAny+        y <- newKindVar KindAny+        let nv = (KVar x `Kfun` KVar y)+        varBind var nv+        f nv as fk+    f _ _ _ = error "KindInfer.kiApps': bad."++kiPred :: HsAsst -> Ki ()+kiPred asst@(HsAsst n ns) = do+    env <- getEnv+    let f k n = do+            k' <- lookupKind KindAny (toName TypeVal n)+            unify k k'+    case Map.lookup n (kindEnvClasses env) of+        Nothing -> do+                addWarn (UndefinedName n) ("Incorrect number of class parameters for " ++ show asst)+--        ,fail $ "unknown class: " ++ show asst+        Just ks -> do+            when (length ks /= length ns) $+                addWarn InvalidDecl ("Incorrect number of class parameters for " ++ show n)+            zipWithM_ f ks ns+kiPred (HsAsstEq a b) = do+    mv <- newKindVar KindSimple+    kiType  (KVar mv) a+    kiType' (KVar mv) b++-- first pass over declarations adds classes to environment.+kiInitClasses :: [HsDecl] -> Ki ()+kiInitClasses ds = do mapM_ kiInitDecl ds++kiInitDecl :: HsDecl -> Ki ()+kiInitDecl d = withSrcLoc (srcLoc d) (f d) where+    f HsClassDecl { .. } = do+        args <- mapM (\_ -> newKindVar KindAny) (hsClassHeadArgs hsDeclClassHead)+        extendEnv mempty { kindEnvClasses =+            Map.singleton (hsClassHead hsDeclClassHead) (map KVar args) }+    f _ = return ()+kiDecl :: HsDecl -> Ki ()+kiDecl d = withSrcLoc (srcLoc d) (f d) where+    varLike HsTyVar {} = True+    varLike HsTyExpKind { hsTyLType = Located _ t } = varLike t+    varLike _ = False+    consLike (HsTyFun a b) = varLike a && varLike b+    consLike (HsTyTuple ts) = all varLike ts+    consLike t = case fromHsTypeApp t of+        (HsTyCon {},as) -> all varLike as+        _ -> False+    f HsTypeFamilyDecl { .. } = do+        kc <- lookupKind KindSimple (toName TypeConstructor hsDeclName)+        kiApps kc hsDeclTArgs (maybe kindStar hsKindToKind hsDeclHasKind)+    f HsDataDecl { hsDeclDeclType = DeclTypeKind, .. } = kiDataKind hsDeclName hsDeclCons+    f HsDataDecl {+            hsDeclContext = context,+            hsDeclName = tyconName,+            hsDeclArgs = args,+            hsDeclCons = [],+            hsDeclHasKind = Just kk } = do+        args <- mapM (lookupKind KindSimple . toName TypeVal) args+        kc <- lookupKind KindAny (toName TypeConstructor tyconName)+        kiApps' kc args (hsKindToKind kk)+        mapM_ kiPred context+    f HsDataDecl { hsDeclDeclType = DeclTypeNewtype, .. } = kiAlias hsDeclContext hsDeclName hsDeclArgs (head hsDeclCons)+    f HsDataDecl { .. }    = kiData hsDeclContext hsDeclName hsDeclArgs hsDeclCons+    f HsTypeDecl { hsDeclName = name, hsDeclTArgs = args, hsDeclType = ty } = do+        wh <- asks kiWhere+        let theconstraint = if wh == Other then KindAny else KindSimple+        kc <- lookupKind theconstraint (toName TypeConstructor name)+        mv <- newKindVar theconstraint+        kiApps kc args (KVar mv)+        kiType' (KVar mv) ty+    f (HsTypeSig _ _ (HsQualType ps t)) = do+        mapM_ kiPred ps+        kiType kindStar t+    f (HsClassDecl _sloc HsClassHead { .. } sigsAndDefaults) = do+        when (length hsClassHeadArgs /= 1) $+            addWarn UnsupportedFeature "Multi-parameter type classes not supported"+        unless (all varLike hsClassHeadArgs) $+            addWarn InvalidDecl "Class parameters must be variables"+        env <- getEnv+        let ks = kindOfClass hsClassHead env+            [fromHsTyVar -> Just classArg] = hsClassHeadArgs+        zipWithM_ kiType' ks hsClassHeadArgs+        mapM_ kiPred hsClassHeadContext+        let rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty g) newClassBodies+            newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults+            typeFromSig (HsTypeSig _sloc _names qualType) = qualType+            typeFromSig _ = error "KindInfer.typeFromSig: bad."+            g (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n')+            g _ = Seq.empty+        carg <- lookupKind KindSimple (toName TypeVal classArg)+        mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn+        local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults+    f HsDeclDeriving { hsDeclClassHead = ch } = checkInstance ch+    f HsInstDecl { hsDeclClassHead = ch } = checkInstance ch+    f _ = return ()+    checkInstance HsClassHead { .. } = do+        unless (all consLike hsClassHeadArgs) $+            addWarn InvalidDecl "Instance parameters must be of the form 'C v1 v2'"+        mapM_ kiPred hsClassHeadContext+        env <- getEnv+        let ks = kindOfClass hsClassHead env+        when (length ks /= length hsClassHeadArgs) $+            addWarn InvalidDecl "Incorrect number of class parameters in instance head"+        zipWithM_ kiType' ks hsClassHeadArgs+  --      HsQualType contxt (HsTyApp (HsTyCon _className) (HsTyVar classArg)) =  qualType+  --      ans = do+  --          carg <- lookupKind KindSimple (toName TypeVal classArg)+  --          mapM_ kiPred contxt+--            extendEnv mempty { kindEnvAssocs = Map.fromList assocs }+--            mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn+--            local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults++--        numClassArgs = 1+--        newAssocs = [ (name,[ n | ~(HsTyVar n) <- names],t,names) | HsTypeDecl _sloc name names t <- sigsAndDefaults ]+--        assocs = [ (toName TypeConstructor n,(numClassArgs,length names - numClassArgs)) | (n,names,_,_) <- newAssocs ]+--        rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs)+--        newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults+--        f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n')+--        f _ = Seq.empty+--        typeFromSig :: HsDecl -> HsQualType+--        typeFromSig (HsTypeSig _sloc _names qualType) = qualType++fromHsTypeApp t = f t [] where+    f (HsTyApp a b) rs = f a (b:rs)+    f t rs = (t,rs)++kiAlias context tyconName args condecl = do+    args <- mapM (lookupKind KindSimple . toName TypeVal) args+    kc <- lookupKind KindAny (toName TypeConstructor tyconName)+    let [a] = hsConDeclArgs condecl+    va <- newKindVar KindQuestQuest+    kiApps' kc args (KVar va)+    kiType (KVar va) (hsBangType a)+    mapM_ kiPred context++kiData context tyconName args condecls = do+    args <- mapM (lookupKind KindSimple . toName TypeVal) args+    kc <- lookupKind KindSimple (toName TypeConstructor tyconName)+    kiApps' kc args kindStar+    mapM_ kiPred context+    flip mapM_  (concatMap (map hsBangType . hsConDeclArgs) condecls) $ \t -> do+        v <- newKindVar KindQuestQuest+        kiType (KVar v) t++kiDataKind tyconName condecls = do+    unless (nameType tyconName == SortName) $ fail "tycon isn't sort"+    flip mapM_  condecls $ \ HsConDecl { .. } -> do+        kc <- lookupKind KindAny (toName TypeConstructor hsConDeclName)+        let args = [ KBase (KNamed t) | HsTyCon t <- map hsBangType hsConDeclConArg ]+        kiApps' kc args (KBase (KNamed tyconName))++kiHsQualType :: KindEnv -> HsQualType -> KindEnv+kiHsQualType inputEnv qualType@(HsQualType ps t) = newState where+    newState = unsafePerformIO $ runKI inputEnv $ withContext ("kiHsQualType: " ++ show qualType) $ do+        kiType kindStar t+        mapM_ kiPred ps+        getEnv >>= postProcess++--------------------------------------------------------------------------------++kindOf :: Name -> KindEnv -> Kind+kindOf name KindEnv { kindEnv = env } = case Map.lookup name env of+--          Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar+            Just k -> k+            _ -> error $ "kindOf: could not find kind of : " ++ show (nameType name,name)++kindOfClass :: Name -> KindEnv -> [Kind]+kindOfClass name KindEnv { kindEnvClasses = cs } = case Map.lookup name cs of+        --Nothing -> Star+        --Nothing -> error $ "kindOf: could not find kind of class : " ++ show (nameType name,name)+        Nothing -> [] -- error $ "kindOf: could not find kind of class : " ++ show (nameType name,name)+        Just k -> k++----------------------+-- Conversion of Types+----------------------++fromTyApp t = f t [] where+    f (HsTyApp a b) rs = f a (b:rs)+    f t rs = (t,rs)++aHsTypeToType :: KindEnv -> HsType -> Type+aHsTypeToType kt@KindEnv { kindEnvAssocs = at } t | (HsTyCon con,xs) <- fromTyApp t, let nn = toName TypeConstructor con, Just (n1,n2) <- Map.lookup nn at =+    TAssoc {+        typeCon = Tycon nn (kindOf nn kt),+        typeClassArgs = map (aHsTypeToType kt) (take n1 xs),+        typeExtraArgs = map (aHsTypeToType kt) (take n2 $ drop n1 xs)+    }+aHsTypeToType kt (HsTyFun t1 t2) = aHsTypeToType kt t1 `fn` aHsTypeToType kt t2+aHsTypeToType kt HsTyExpKind { hsTyLType = Located _ t } = aHsTypeToType kt t+aHsTypeToType kt tuple@(HsTyTuple types) = tTTuple $ map (aHsTypeToType kt) types+aHsTypeToType kt tuple@(HsTyUnboxedTuple types) = tTTuple' $ map (aHsTypeToType kt) types+aHsTypeToType kt (HsTyApp t1 t2) = tAp (aHsTypeToType kt t1) (aHsTypeToType kt t2)++-- variables, we must know the kind of the variable here!+-- they are assumed to already exist in the kindInfoTable+-- which was generated by the process of KindInference++aHsTypeToType kt (HsTyVar name) = TVar $ toTyvar kt name --  tyvar  name (kindOf name kt) Nothing++-- type constructors, we must know the kind of the constructor.+-- here we also qualify the type constructor if it is+-- currently unqualified++aHsTypeToType kt (HsTyCon name) = TCon $ Tycon nn (kindOf nn kt)  where+    nn =  (toName TypeConstructor name)++aHsTypeToType kt (HsTyForall vs qt) = TForAll (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt)+aHsTypeToType kt (HsTyExists vs qt) = TExists (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt)++aHsTypeToType _ t = error $ "aHsTypeToType: " ++ show t++toTyvar kt name =  tyvar  nn (kindOf nn kt) where+    nn = toName TypeVal name++aHsQualTypeToQualType :: KindEnv -> HsQualType -> Qual Type+aHsQualTypeToQualType kt (HsQualType cntxt t) = map (hsAsstToPred kt) cntxt :=> aHsTypeToType kt t++hsAsstToPred :: KindEnv -> HsAsst -> Pred+hsAsstToPred kt (HsAsst className [varName])+   -- = IsIn className (TVar $ Tyvar varName (kindOf varName kt))+   | isConstructorLike varName = IsIn  (toName ClassName className) (TCon (Tycon (toName TypeConstructor varName) (head $ kindOfClass (toName ClassName className) kt)))+   | otherwise = IsIn (toName ClassName className) (TVar $ tyvar (toName TypeVal varName) (head $ kindOfClass (toName ClassName className) kt))+hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType' kt t1) (runIdentity $ hsTypeToType' kt t2)+hsAsstToPred _ _ = error "KindInfer.hsAsstToPred: bad."++hsQualTypeToSigma kt qualType = hsQualTypeToType kt (Just []) qualType++hsTypeToType :: Monad m => KindEnv -> HsType -> m Type+hsTypeToType kt t = return $ unsafePerformIO $ runKI kt $+                    do kv <- newKindVar KindAny+                       kiType (KVar kv) t+                       kt' <- postProcess =<< getEnv+                       hsTypeToType' kt' t++hsTypeToType' :: Monad m => KindEnv -> HsType -> m Type+hsTypeToType' kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t)++hsQualTypeToType :: Monad m =>+    KindEnv            -- ^ the kind environment+    -> Maybe [HsName]  -- ^ universally quantify free variables excepting those in list.+    -> HsQualType      -- ^ the type to convert+    -> m Sigma+hsQualTypeToType kindEnv qs qualType = return $ hoistType $ tForAll quantOver ( ps' :=> t') where+   newEnv = kiHsQualType kindEnv qualType+   --newEnv = kindEnv+   Just t' = hsTypeToType' newEnv (hsQualTypeType qualType)+   ps = hsQualTypeContext qualType+   ps' = map (hsAsstToPred newEnv) ps+   quantOver = nub $ freeVars ps' ++ fvs+   fvs = case qs of+       Nothing -> []+       Just xs -> [ v | v <- freeVars t', nameName (tyvarName v) `notElem` xs]++hoistType :: Type -> Type+hoistType t = f t where+    f t@TVar {} = t+    f t@TCon {} = t+    f t@TMetaVar {} = t+    f t@TAssoc {} = t { typeClassArgs = map f (typeClassArgs t), typeExtraArgs = map f (typeExtraArgs t) }+    f (TAp a b) = TAp (f a) (f b)+    f (TForAll vs (ps :=> (f -> nt)))+        | (TForAll vs' (ps' :=> t')) <- nt = f $ TForAll (vs ++ vs') ((ps ++ ps') :=> t')+        | otherwise = TForAll vs (ps :=> nt)+    f (TExists vs (ps :=> (f -> nt)))+        | (TExists vs' (ps' :=> t')) <- nt = f $ TExists (vs ++ vs') ((ps ++ ps') :=> t')+        | otherwise = TExists vs (ps :=> nt)+    f (TArrow (f -> na) (f -> nb))+        | TForAll vs (ps :=> t) <- nb = f $ TForAll vs (ps :=> TArrow na t)+        | TExists vs (ps :=> t) <- na = f $ TForAll vs (ps :=> TArrow t nb)+        | otherwise = TArrow na nb++fromHsTyVar (HsTyVar v) = return v+fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t+fromHsTyVar _ = fail "fromHsTyVar"+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Monoid KindEnv where+    mempty = KindEnv mempty mempty mempty+    mappend (KindEnv aa ab ac) (KindEnv aa' ab' ac') = KindEnv (mappend aa aa')(mappend ab ab')(mappend ac ac')++--  Imported from other files :-
+ drift_processed/FrontEnd/Representation.hs view
@@ -0,0 +1,459 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/Representation.hs" #-}+module FrontEnd.Representation(+    Type(..),+    Tyvar(..),+    tyvar,+    Tycon(..),+    fn,+    Pred(..),+    Qual(..),+    Class,+    tForAll,+    tExists,+    MetaVarType(..),+    prettyPrintType,+    fromTAp,+    fromTArrow,+    tassocToAp,+    MetaVar(..),+    tTTuple,+    tTTuple',+    tList,+    tArrow,+    tAp+    )where++import Control.Monad.Identity+import Data.IORef++import Data.Binary+import Doc.DocLike+import Doc.PPrint+import FrontEnd.Tc.Kind+import Name.Name+import Name.Names+import Name.VConsts+import Support.CanType+import Support.Unparse+import Util.VarName++-- Types++data MetaVarType = Tau | Rho | Sigma+             deriving(Eq,Ord)+    {-! derive: Binary !-}++data Type  = TVar     { typeVar :: !Tyvar }+           | TCon     { typeCon :: !Tycon }+           | TAp      Type Type+           | TArrow   Type Type+           | TForAll  { typeArgs :: [Tyvar], typeBody :: (Qual Type) }+           | TExists  { typeArgs :: [Tyvar], typeBody :: (Qual Type) }+           | TMetaVar { metaVar :: MetaVar }+           | TAssoc   { typeCon :: !Tycon, typeClassArgs :: [Type], typeExtraArgs :: [Type] }+             deriving(Ord,Show)+    {-! derive: Binary !-}++-- | metavars are used in type checking+data MetaVar = MetaVar {+    metaUniq :: {-# UNPACK #-} !Int,+    metaKind :: Kind,+    metaRef :: {-# UNPACK #-} !(IORef (Maybe Type)),+    metaType :: !MetaVarType+    }+    {-! derive: Binary !-}++instance Eq MetaVar where+    a == b = metaUniq a == metaUniq b++instance Ord MetaVar where+    compare a b = compare (metaUniq a) (metaUniq b)++instance TypeNames Type where+    tBool   = TCon (Tycon tc_Bool kindStar)+    tString = TAp tList tChar+    tChar   = TCon (Tycon tc_Char kindStar)+    tUnit   = TCon (Tycon tc_Unit kindStar)+    tCharzh = TCon (Tycon tc_Char_ kindHash)++instance Ord (IORef a)+instance Binary (IORef a) where+  put = error "Binary.put: not impl."+  get = error "Binary.get: not impl."++tList :: Type+tList = TCon (Tycon tc_List (Kfun kindStar kindStar))++-- | The @(->)@ type constructor. Invariant: @tArrow@ shall not be fully applied. To this end, see 'tAp'.+tArrow :: Type+tArrow = TCon (Tycon tc_Arrow (kindArg `Kfun` (kindFunRet `Kfun` kindStar)))++-- | Type application, enforcing the invariant that there be no fully-applied 'tArrow's+tAp :: Type -> Type -> Type+tAp (TAp c@TCon{} a) b | c == tArrow = TArrow a b+tAp a b = TAp a b++instance Eq Type where+    (TVar a) == (TVar b) = a == b+    (TMetaVar a) == (TMetaVar b) = a == b+    (TCon a) == (TCon b) = a == b+    (TAp a' a) == (TAp b' b) = a' == b' && b == a+    (TArrow a' a) == (TArrow b' b) = a' == b' && b == a+    _ == _ = False++tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl tAp (TCon con) (cas ++ eas)+tassocToAp _ = error "Representation.tassocToAp: bad."++-- Unquantified type variables++data Tyvar = Tyvar { tyvarName ::  {-# UNPACK #-} !Name, tyvarKind :: Kind }+    {-  derive: Binary -}++instance Show Tyvar where+    showsPrec _ Tyvar { tyvarName = hn, tyvarKind = k } = shows hn . ("::" ++) . shows k++tForAll [] ([] :=> t) = t+tForAll vs (ps :=> TForAll vs' (ps' :=> t)) = tForAll (vs ++ vs') ((ps ++ ps') :=> t)+tForAll x y = TForAll x y++tExists [] ([] :=> t) = t+tExists vs (ps :=> TExists vs' (ps' :=> t)) = tExists (vs ++ vs') ((ps ++ ps') :=> t)+tExists x y = TExists x y++tyvar n k = Tyvar n k++instance Eq Tyvar where+    Tyvar { tyvarName = x } == Tyvar { tyvarName = y } = x == y+    Tyvar { tyvarName = x } /= Tyvar { tyvarName = y } = x /= y++instance Ord Tyvar where+    compare (Tyvar { tyvarName = x }) (Tyvar { tyvarName = y }) = compare x y+    (Tyvar { tyvarName = x }) <= (Tyvar { tyvarName = y }) = x <= y+    (Tyvar { tyvarName = x }) >= (Tyvar { tyvarName = y }) = x >= y+    (Tyvar { tyvarName = x }) <  (Tyvar { tyvarName = y })  = x < y+    (Tyvar { tyvarName = x }) >  (Tyvar { tyvarName = y })  = x > y++-- Type constructors++data Tycon = Tycon { tyconName :: Name, tyconKind :: Kind }+    deriving(Eq, Show,Ord)+    {-! derive: Binary !-}++instance ToTuple Tycon where+    toTuple n = Tycon (nameTuple TypeConstructor n) (foldr Kfun kindStar $ replicate n kindStar)+instance ToTuple Type where+    toTuple n = TCon $ toTuple n++instance DocLike d => PPrint d Tycon where+   pprint (Tycon i _) = pprint i++infixr      4 `fn`+fn         :: Type -> Type -> Type+a `fn` b    = TArrow a b++--------------------------------------------------------------------------------++-- Predicates+data Pred   = IsIn Class Type | IsEq Type Type+              deriving(Show, Eq,Ord)+    {-! derive: Binary !-}++-- Qualified entities+data Qual t =  [Pred] :=> t+              deriving(Show, Eq,Ord)+    {-! derive: Binary !-}++instance (DocLike d,PPrint d t) => PPrint d (Qual t) where+    pprint ([] :=> r) = pprint r+    pprint ([x] :=> r) = pprint x <+> text "=>" <+> pprint r+    pprint (xs :=> r) = tupled (map pprint xs) <+> text "=>" <+> pprint r++instance  DocLike d => PPrint d Tyvar where+  pprint tv = tshow (tyvarName tv)++instance Binary Tyvar where+    put (Tyvar aa ab) = do+        put aa+        put ab+    get = do+        aa <- get+        ab <- get+        return (Tyvar aa ab)++instance DocLike d => PPrint d Module where+   pprint (Module s) = tshow s++withNewNames ts action = subVarName $ do+    ts' <- mapM newTyvarName ts+    action ts'++newTyvarName t = case tyvarKind t of+    x@(KBase Star) -> newLookupName (map (:[]) ['a' ..]) x t+    y@(KBase Star `Kfun` KBase Star) -> newLookupName (map (('f':) . show) [0 :: Int ..]) y t+    z@(KBase KUTuple) -> newLookupName (map (('u':) . show) [0 :: Int ..]) z t+    z@(KBase KQuest) -> newLookupName (map (('q':) . show) [0 :: Int ..]) z t+    z@(KBase KQuestQuest) -> newLookupName (map (('q':) . ('q':) . show) [0 :: Int ..]) z t+    z -> newLookupName (map (('t':) . show) [0 :: Int ..]) z t++prettyPrintType :: DocLike d => Type -> d+prettyPrintType = pprint++instance DocLike d => PPrint d Type where+    pprintAssoc _ n t = prettyPrintTypePrec n t++prettyPrintTypePrec :: DocLike d => Int -> Type -> d+prettyPrintTypePrec n t  = unparse $ zup (runIdentity (runVarNameT (f t))) where+    zup = if n >= 10 then pop empty else id+    arr = bop (R,0) (space <> text "->" <> space)+    app = bop (L,100) (text " ")+    fp (IsIn cn t) = do+        t' <- f t+        return (atom (text $ show cn) `app` t')+    fp (IsEq t1 t2) = do+        t1' <- f t1+        t2' <- f t2+        return (atom (parens $ unparse t1' <+> text "=" <+> unparse t2'))+    f (TForAll [] ([] :=> t)) = f t+    f (TForAll vs (ps :=> t)) = do+        withNewNames vs $ \ts' -> do+        t' <- f t+        ps' <- mapM fp ps+        return $ case ps' of+            [] ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text ". ")  (atomize t')+            [p] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')+            ps ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')+    f (TExists [] ([] :=> t)) = f t+    f (TExists vs (ps :=> t)) = do+        withNewNames vs $ \ts' -> do+        t' <- f t+        ps' <- mapM fp ps+        return $ case ps' of+            [] ->  fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text ". ")  (atomize t')+            [p] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')+            ps ->  fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')+    f (TCon tycon) = return $ atom (pprint tycon)+    f (TVar tyvar) = do+        vo <- maybeLookupName tyvar+        case vo of+            Just c  -> return $ atom $ text c+            Nothing -> return $ atom $ tshow (tyvarName tyvar)+    f (TAp (TCon (Tycon n _)) x) | n == tc_List = do+        x <- f x+        return $ atom (char '[' <> unparse x <> char ']')+    f TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = do+        let x = atom (pprint con)+        xs <- mapM f (cas ++ eas)+        return $ foldl app x xs+    f ta@(TAp {}) | (TCon (Tycon c _),xs) <- fromTAp ta, Just _ <- fromTupname c = do+        xs <- mapM f xs+        return $ atom (tupled (map unparse xs))+    f (TAp t1 t2) = do+        t1 <- f t1+        t2 <- f t2+        return $ t1 `app` t2+    f (TArrow t1 t2) = do+        t1 <- f t1+        t2 <- f t2+        return $ t1 `arr` t2+    f (TMetaVar mv) = return $ atom $ pprint mv+    --f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv)++instance DocLike d => PPrint d MetaVarType where+    pprint  t = case t of+        Tau -> char 't'+        Rho -> char 'r'+        Sigma -> char 's'++instance DocLike d => PPrint d Pred where+    pprint (IsIn c t) = tshow c <+> pprintParen t+    pprint (IsEq t1 t2) = parens $ prettyPrintType t1 <+> text "=" <+> prettyPrintType t2++instance DocLike d => PPrint d MetaVar where+    pprint MetaVar { metaUniq = u, metaKind = k, metaType = t }+        | KBase Star <- k =  pprint t <> tshow u+        | otherwise = parens $ pprint t <> tshow u <> text " :: " <> pprint k++instance Show MetaVarType where+    show mv = pprint mv++instance Show MetaVar where+    show mv = pprint mv++fromTAp t = f t [] where+    f (TAp a b) rs = f a (b:rs)+    f t rs = (t,rs)++fromTArrow t = f t [] where+    f (TArrow a b) rs = f b (a:rs)+    f t rs = (reverse rs,t)++instance CanType MetaVar where+    type TypeOf MetaVar = Kind+    getType mv = metaKind mv++instance CanType Tycon where+    type TypeOf Tycon = Kind+    getType (Tycon _ k) = k++instance CanType Tyvar where+    type TypeOf Tyvar = Kind+    getType = tyvarKind++instance CanType Type where+    type TypeOf Type = Kind+    getType (TCon tc) = getType tc+    getType (TVar u)  = getType u+    getType typ@(TAp t _) = case (getType t) of+                       (Kfun _ k) -> k+                       x -> error $ "Representation.getType: kind error in: " ++ (show typ)+    getType (TArrow _l _r) = kindStar+    getType (TForAll _ (_ :=> t)) = getType t+    getType (TExists _ (_ :=> t)) = getType t+    getType (TMetaVar mv) = getType mv+    getType ta@TAssoc {} = getType (tassocToAp ta)++tTTuple ts | length ts < 2 = error "tTTuple"+tTTuple ts = foldl TAp (toTuple (length ts)) ts++tTTuple' ts = foldl TAp (TCon $ Tycon (unboxedNameTuple TypeConstructor  n) (foldr Kfun kindUTuple $ replicate n kindStar)) ts where+    n = length ts+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary MetaVarType where+    put Tau = do+	    Data.Binary.putWord8 0+    put Rho = do+	    Data.Binary.putWord8 1+    put Sigma = do+	    Data.Binary.putWord8 2+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Tau+	      1 -> do+		    return Rho+	      2 -> do+		    return Sigma+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Type where+    put (TVar aa) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+    put (TCon ab) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ab+    put (TAp ac ad) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ac+	    Data.Binary.put ad+    put (TArrow ae af) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ae+	    Data.Binary.put af+    put (TForAll ag ah) = do+	    Data.Binary.putWord8 4+	    Data.Binary.put ag+	    Data.Binary.put ah+    put (TExists ai aj) = do+	    Data.Binary.putWord8 5+	    Data.Binary.put ai+	    Data.Binary.put aj+    put (TMetaVar ak) = do+	    Data.Binary.putWord8 6+	    Data.Binary.put ak+    put (TAssoc al am an) = do+	    Data.Binary.putWord8 7+	    Data.Binary.put al+	    Data.Binary.put am+	    Data.Binary.put an+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    return (TVar aa)+	      1 -> do+		    ab <- Data.Binary.get+		    return (TCon ab)+	      2 -> do+		    ac <- Data.Binary.get+		    ad <- Data.Binary.get+		    return (TAp ac ad)+	      3 -> do+		    ae <- Data.Binary.get+		    af <- Data.Binary.get+		    return (TArrow ae af)+	      4 -> do+		    ag <- Data.Binary.get+		    ah <- Data.Binary.get+		    return (TForAll ag ah)+	      5 -> do+		    ai <- Data.Binary.get+		    aj <- Data.Binary.get+		    return (TExists ai aj)+	      6 -> do+		    ak <- Data.Binary.get+		    return (TMetaVar ak)+	      7 -> do+		    al <- Data.Binary.get+		    am <- Data.Binary.get+		    an <- Data.Binary.get+		    return (TAssoc al am an)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary MetaVar where+    put (MetaVar aa ab ac ad) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    return (MetaVar aa ab ac ad)++instance Data.Binary.Binary Tycon where+    put (Tycon aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (Tycon aa ab)++instance Data.Binary.Binary Pred where+    put (IsIn aa ab) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+    put (IsEq ac ad) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    return (IsIn aa ab)+	      1 -> do+		    ac <- Data.Binary.get+		    ad <- Data.Binary.get+		    return (IsEq ac ad)+	      _ -> fail "invalid binary data found"++instance (Data.Binary.Binary t) => Data.Binary.Binary (Qual t) where+    put ((:=>) aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return ((:=>) aa ab)++--  Imported from other files :-
+ drift_processed/FrontEnd/SrcLoc.hs view
@@ -0,0 +1,168 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/SrcLoc.hs" #-}+module FrontEnd.SrcLoc where++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.Writer+import Data.Foldable+import Data.Traversable+import Data.Binary+import Data.Generics++import PackedString++data SrcLoc = SrcLoc {+        srcLocFileName :: PackedString,+        srcLocLine :: {-# UNPACK #-} !Int,+        srcLocColumn :: {-# UNPACK #-} !Int+        }+    deriving(Data,Typeable,Eq,Ord)+    {-! derive: update, Binary !-}++data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc }+    deriving(Data,Typeable,Eq,Ord)+    {-! derive: update, Binary !-}++-- Useful bogus file names used to indicate where non file based errors are.+fileNameCommandLine = packString "(command line)"+fileNameUnknown = packString "(unknown)"+fileNameGenerated = packString "(generated)"++bogusASrcLoc = SrcLoc fileNameUnknown (-1) (-1)+bogusSrcSpan = SrcSpan bogusASrcLoc bogusASrcLoc++instance Monoid SrcLoc where+    mempty = bogusASrcLoc+    mappend a b+        | a == bogusASrcLoc = b+        | otherwise = a++--------------------+-- haslocation class+--------------------++class HasLocation a where+    srcLoc :: a -> SrcLoc+    srcSpan :: a -> SrcSpan+    srcSpan x = bogusSrcSpan { srcSpanBegin = slx, srcSpanEnd = slx } where slx = srcLoc x+    srcLoc x = srcSpanBegin (srcSpan x)++instance HasLocation a => HasLocation [a] where+    srcLoc xs = mconcat (map srcLoc xs)++instance HasLocation SrcLoc where+    srcLoc x = x++instance HasLocation SrcSpan where+    srcSpan x = x++instance HasLocation (SrcLoc,SrcLoc) where+    srcSpan (x,y) = SrcSpan x y++instance HasLocation (Located a) where+    srcSpan (Located x _) = x++data Located x = Located SrcSpan x+    deriving(Ord,Show,Data,Typeable,Eq)+    {-! derive: Binary !-}++fromLocated :: Located x -> x+fromLocated (Located _ x) = x++instance Functor Located where+    fmap f (Located l x) = Located l (f x)++instance Foldable Located where+    foldMap f (Located l x) = f x++instance Traversable Located where+    traverse f (Located l x) = Located l <$> f x++located ss x = Located (srcSpan ss) x++-----------------------+-- srcloc monad classes+-----------------------++class Monad m => MonadSrcLoc m where+    getSrcLoc  :: m SrcLoc+    getSrcSpan :: m SrcSpan+    getSrcSpan = getSrcLoc >>= return . srcSpan+    getSrcLoc = getSrcSpan >>= return . srcLoc++class MonadSrcLoc m => MonadSetSrcLoc m where+    withSrcLoc :: SrcLoc -> m a -> m a+    withSrcSpan :: SrcSpan -> m a -> m a+    withSrcLoc sl a = withSrcSpan (srcSpan sl) a+    withSrcSpan ss a = withSrcLoc (srcLoc ss) a++withLocation :: (HasLocation l,MonadSetSrcLoc m) => l -> m a -> m a+withLocation l = withSrcSpan (srcSpan l)++instance Monoid w => MonadSrcLoc (Writer w) where+    getSrcLoc = return mempty+instance Monoid w => MonadSetSrcLoc (Writer w) where+    withSrcLoc _ a = a++instance MonadSrcLoc Identity where+    getSrcLoc = return mempty+instance MonadSetSrcLoc Identity where+    withSrcLoc _ a = a++-----------------+-- show instances+-----------------++instance Show SrcLoc where+    show (SrcLoc fn l c) = unpackPS fn ++ f l ++ f c where+        f (-1) = ""+        f n = ':':show n++instance Show SrcSpan where+    show SrcSpan { srcSpanBegin =  sl1, srcSpanEnd = sl2 }+      | sl1 == sl2 = show sl1+      | otherwise = show sl1 ++ "-" ++ show sl2+{-* Generated by DrIFT : Look, but Don't Touch. *-}+srcLocColumn_u f r@SrcLoc{srcLocColumn  = x} = r{srcLocColumn = f x}+srcLocFileName_u f r@SrcLoc{srcLocFileName  = x} = r{srcLocFileName = f x}+srcLocLine_u f r@SrcLoc{srcLocLine  = x} = r{srcLocLine = f x}+srcLocColumn_s v =  srcLocColumn_u  (const v)+srcLocFileName_s v =  srcLocFileName_u  (const v)+srcLocLine_s v =  srcLocLine_u  (const v)++instance Data.Binary.Binary SrcLoc where+    put (SrcLoc aa ab ac) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+    get = do+    aa <- get+    ab <- get+    ac <- get+    return (SrcLoc aa ab ac)++srcSpanBegin_u f r@SrcSpan{srcSpanBegin  = x} = r{srcSpanBegin = f x}+srcSpanEnd_u f r@SrcSpan{srcSpanEnd  = x} = r{srcSpanEnd = f x}+srcSpanBegin_s v =  srcSpanBegin_u  (const v)+srcSpanEnd_s v =  srcSpanEnd_u  (const v)++instance Data.Binary.Binary SrcSpan where+    put (SrcSpan aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (SrcSpan aa ab)++instance (Data.Binary.Binary x) => Data.Binary.Binary (Located x) where+    put (Located aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (Located aa ab)++--  Imported from other files :-
+ drift_processed/FrontEnd/Tc/Kind.hs view
@@ -0,0 +1,229 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/Tc/Kind.hs" #-}+module FrontEnd.Tc.Kind(+    Kind(..),+    KBase(..),+    Kindvar(..),+    KindConstraint(..),+    kindCombine,+    kindStar,+    kindUTuple,+    kindFunRet,+    kindHash,+    kindArg,+    isSubsumedBy,+    unfoldKind+    ) where++import Control.Monad+import Data.IORef+import Data.Monoid++import Data.Binary+import Doc.DocLike+import Doc.PPrint(pprint,pprintPrec,pprintAssoc,Assoc(..),PPrint,pprintBinary)+import Name.Name++{-++ KQuest = ?        star or hash or unboxed tuple+ KQuestQuest = ??  star or hash+ KUTuple = (#)     unboxed tuple+ Star    = *       boxed value+ KHash   = #       unboxed value+ Kfun    = (->)+ KNamed Foo = Foo  named kind++ we have the following subkinding going on++       ?+      / \+     ?? (#)+     /\+    *  #++in addition, user defined named kinds are allowed. these can only occur via+kind annotations, and only unify with themselves++-}++data KBase =+        Star+        | KHash+        | KUTuple+        | KQuestQuest+        | KQuest+        | KNamed Name+    deriving(Eq, Ord)   -- but we need them for kind inference+    {-! derive: Binary !-}++KNamed s1 `isSubsumedBy2` KNamed s2   = s1 == s2+_         `isSubsumedBy2` KQuest      = True+Star      `isSubsumedBy2` KQuestQuest = True+KHash     `isSubsumedBy2` KQuestQuest = True+k1        `isSubsumedBy2` k2          = k1 == k2++kindStar   = KBase Star+kindHash   = KBase KHash+kindUTuple = KBase KUTuple+kindFunRet = KBase KQuest+kindArg    = KBase KQuestQuest++infixr 5 `Kfun`++data Kind  = KBase KBase+           | Kfun Kind Kind+           | KVar Kindvar               -- variables aren't really allowed in haskell in kinds+             deriving(Eq, Ord)   -- but we need them for kind inference+    {-! derive: Binary !-}++KBase kb    `isSubsumedBy` KBase kb'    = isSubsumedBy2 kb kb'+Kfun  k1 k2 `isSubsumedBy` Kfun k1' k2' = isSubsumedBy k1 k1' && isSubsumedBy k2 k2'+_           `isSubsumedBy` _            = False++kindCombine :: Monad m => Kind -> Kind -> m Kind+kindCombine x y = g x y where+    f x y | x == y = return x++    f KQuest x = fquest x+    f x  KQuest = fquest x+    f KQuestQuest x = fquest2 x+    f x  KQuestQuest = fquest2 x+    f x y = fail $ "kindCombine: " ++ show (x,y)+    fquest (KNamed n) = fail $ "Attempt to unify named kind" <+> tshow n <+> "with ?"+    fquest x = return x+    fquest2 (KNamed n) = fail $ "Attempt to unify named kind" <+> tshow n <+> "with ??"+    fquest2 KUTuple = fail $ "Attempt to unify unboxed tuple with ??"+    fquest2 KQuest = return KQuestQuest+    fquest2 x = return x+    g (KBase x) (KBase y) = f x y >>= return . KBase+    g (Kfun a b) (Kfun a' b') = return Kfun `ap` g a a' `ap` g b b'+    g x y = fail $ "kindCombine: " ++ show (x,y)++data KindConstraint+    = KindSimple     -- ^ * | kindSimple -> kindSimple+    | KindQuest      -- ^ ?, so * or (#) or #+    | KindQuestQuest -- ^ ??, * or #+    | KindStar       -- ^ must be *+    | KindAny        -- ^ may be anything+    deriving(Eq,Ord,Show)++-- note that named kinds are never infered, so we don't need constraints+-- mentioning them.++instance Monoid KindConstraint where+    mempty = KindAny+    mappend a b | a == b = a+    mappend KindAny k = k+    mappend KindStar _ = KindStar+    mappend KindSimple KindQuest = KindStar+    mappend KindSimple KindQuestQuest = KindStar+    mappend KindQuest KindQuestQuest = KindQuestQuest+    mappend k1 k2 = mappend k2 k1++data Kindvar = Kindvar {+    kvarUniq       :: {-# UNPACK #-} !Int,+    kvarRef        :: {-# UNPACK #-} !(IORef (Maybe Kind)),+    kvarConstraint :: !KindConstraint+    }++instance Binary Kindvar where+    put _ = return ()+    get = return (error "Binary.Kindvar.get")++instance Eq Kindvar where+    a == b = kvarUniq a == kvarUniq b++instance Ord Kindvar where+    a `compare` b = kvarUniq a `compare` kvarUniq b++instance Show Kind where+    showsPrec n k = pprintPrec n k++instance Show Kindvar where+    showsPrec n k = pprintPrec n k++instance Show KBase where+    showsPrec _ Star    = showString "*"+    showsPrec _ KUTuple = showString "(#)"+    showsPrec _ KHash   = showString "#"+    showsPrec _ KQuest  = showString "?"+    showsPrec _ KQuestQuest = showString "??"+    showsPrec _ (KNamed n) = shows n++instance DocLike d => PPrint d KBase where+    pprint kb = text (show kb)++instance DocLike d => PPrint d Kind where+   pprintAssoc _ _ (KBase b) = pprint b+   pprintAssoc _ _ (KVar kindVar)   = pprint kindVar+   pprintAssoc a n (Kfun k1 k2) = pprintBinary AssocRight 5 a n k1 (text "->") k2 -- checkAssoc AssocRight 5 a n $ pprintPrec 5 k1 <+> text "->" <+> pprintAssoc AssocRight 5 k2++instance DocLike d =>  PPrint d Kindvar where+   pprint Kindvar { kvarUniq = s } = text $ 'k':show s++--  * -> * == [*,*]+--  (*->*->*) -> * -> * == [(*->*->*), *, *]+unfoldKind :: Kind -> [Kind]+unfoldKind (Kfun k1 k2) = k1 : unfoldKind k2+unfoldKind v = [v]+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Data.Binary.Binary KBase where+    put Star = do+	    Data.Binary.putWord8 0+    put KHash = do+	    Data.Binary.putWord8 1+    put KUTuple = do+	    Data.Binary.putWord8 2+    put KQuestQuest = do+	    Data.Binary.putWord8 3+    put KQuest = do+	    Data.Binary.putWord8 4+    put (KNamed aa) = do+	    Data.Binary.putWord8 5+	    Data.Binary.put aa+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return Star+	      1 -> do+		    return KHash+	      2 -> do+		    return KUTuple+	      3 -> do+		    return KQuestQuest+	      4 -> do+		    return KQuest+	      5 -> do+		    aa <- Data.Binary.get+		    return (KNamed aa)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Kind where+    put (KBase aa) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+    put (Kfun ab ac) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ab+	    Data.Binary.put ac+    put (KVar ad) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ad+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    return (KBase aa)+	      1 -> do+		    ab <- Data.Binary.get+		    ac <- Data.Binary.get+		    return (Kfun ab ac)+	      2 -> do+		    ad <- Data.Binary.get+		    return (KVar ad)+	      _ -> fail "invalid binary data found"++--  Imported from other files :-
+ drift_processed/FrontEnd/Tc/Monad.hs view
@@ -0,0 +1,571 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/FrontEnd/Tc/Monad.hs" #-}+{-# LANGUAGE ImpredicativeTypes #-}+module FrontEnd.Tc.Monad(+    CoerceTerm(..),+    Tc(),+    TcInfo(..),+    TypeEnv(),+    TcEnv(..),+    tcRecursiveCalls_u,+    Output(..),+    addCoerce,+    addPreds,+    composeCoerce,+    addRule,+    addToCollectedEnv,+    boxyInstantiate,+    boxySpec,+    deconstructorInstantiate,+    freeMetaVarsEnv,+    freshInstance,+    freshSigma,+    getClassHierarchy,+    getCollectedEnv,+    getCollectedCoerce,+    getDeName,+    getKindEnv,+    getSigEnv,+    evalFullType,+    inst,+    listenCheckedRules,+    listenPreds,+    listenCPreds,+    localEnv,+    lookupName,+    newBox,+    newMetaVar,+    newVar,+    quantify,+    quantify_n,+    runTc,+    skolomize,+    tcInfoEmpty,+    toSigma,+    unBox,+    evalType,+    unificationError,+    varBind,+    zonkKind,+    withContext,+    withMetaVars+    ) where++import Control.Monad.Error+import Control.Monad.Reader+import Control.Monad.Writer.Strict+import Data.IORef+import Data.List+--import Text.PrettyPrint.HughesPJ(Doc)+import qualified Data.Foldable as T+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Traversable as T++import Doc.DocLike+import Doc.PPrint+import FrontEnd.Class+import FrontEnd.Diagnostic+import FrontEnd.KindInfer+import FrontEnd.Rename(DeNameable(..))+import FrontEnd.SrcLoc(bogusASrcLoc,MonadSrcLoc(..))+import FrontEnd.Tc.Kind+import FrontEnd.Tc.Type+import FrontEnd.Warning+import GenUtil+import Name.Name+import Name.Names+import Options+import Support.CanType+import Support.FreeVars+import Support.Tickle+import qualified FlagDump as FD+import {-# SOURCE #-} FrontEnd.Tc.Class(simplify)++-- data BindingType = RecursiveInfered | Supplied+type TypeEnv = Map.Map Name Sigma++-- read only environment, set up before type checking.+data TcEnv = TcEnv {+    tcInfo              :: TcInfo,+    tcDiagnostics       :: [Diagnostic],   -- list of information that might help diagnosis+    tcVarnum            :: {-# UNPACK #-} !(IORef Int),+    tcCollectedEnv      :: {-# UNPACK #-} !(IORef (Map.Map Name Sigma)),+    tcCollectedCoerce   :: {-# UNPACK #-} !(IORef (Map.Map Name CoerceTerm)),+    tcConcreteEnv       :: Map.Map Name Sigma,+    tcMutableEnv        :: Map.Map Name Sigma,+    tcCurrentScope      :: Set.Set MetaVar,+    tcRecursiveCalls    :: Set.Set Name,+    tcInstanceEnv       :: InstanceEnv,+    tcOptions           :: Opt  -- module specific options+    }++tcConcreteEnv_u    f r@TcEnv{tcConcreteEnv  = x} = r{tcConcreteEnv = f x}+tcDiagnostics_u    f r@TcEnv{tcDiagnostics  = x} = r{tcDiagnostics = f x}+tcMutableEnv_u     f r@TcEnv{tcMutableEnv  = x}  = r{tcMutableEnv = f x}+tcRecursiveCalls_u f r@TcEnv{tcRecursiveCalls  = x} = r{tcRecursiveCalls = f x}++data Output = Output {+    collectedPreds   :: !Preds,+    existentialPreds :: !Preds,+    constraints      :: !(Seq.Seq Constraint),+    checkedRules     :: !(Seq.Seq Rule),+    existentialVars  :: [Tyvar],+    tcWarnings       :: !(Seq.Seq Warning),+    outKnots         :: [(Name,Name)]+    }+   {-! derive: Monoid !-}++newtype Tc a = Tc (ReaderT TcEnv (WriterT Output IO) a)+    deriving(MonadFix,MonadIO,MonadReader TcEnv,MonadWriter Output,Functor)++-- | information that is passed into the type checker.+data TcInfo = TcInfo {+    tcInfoEnv            :: TypeEnv, -- initial typeenv, data constructors, and previously infered types+    tcInfoSigEnv         :: TypeEnv, -- type signatures used for binding analysis+    tcInfoModName        :: Module,+    tcInfoKindInfo       :: KindEnv,+    tcInfoClassHierarchy :: ClassHierarchy+    }++getDeName :: DeNameable n => Tc (n -> n)+getDeName = do+    mn <- asks (tcInfoModName . tcInfo)+    return (\n -> deName mn n)++-- | run a computation with a local environment+localEnv :: TypeEnv -> Tc a -> Tc a+localEnv te act = do+    te' <- T.mapM flattenType te+    let (cenv,menv) = Map.partition (Set.null . freeMetaVars) te'+    --if any isBoxy (Map.elems te') then+    --    fail $ "localEnv error!\n" ++ show te+    local (tcConcreteEnv_u (cenv `Map.union`) . tcMutableEnv_u ((menv `Map.union`) .+        Map.filterWithKey (\k _ -> k `Map.notMember` cenv))) act++-- | add to the collected environment which will be used to annotate uses of+-- variables with their instantiated types.  should contain @-aliases for each+-- use of a polymorphic variable or pattern match.++addToCollectedEnv :: TypeEnv -> Tc ()+addToCollectedEnv te = do+    v <- asks tcCollectedEnv+    liftIO $ modifyIORef v (te `Map.union`)++addCoerce :: Name -> CoerceTerm -> Tc ()+addCoerce n te = do+    v <- asks tcCollectedCoerce+    liftIO $ modifyIORef v (Map.insert n te)++getCollectedEnv :: Tc TypeEnv+getCollectedEnv = do+    v <- asks tcCollectedEnv+    r <- liftIO $ readIORef v+    r <- T.mapM flattenType r+    return r++getCollectedCoerce :: Tc (Map.Map Name CoerceTerm)+getCollectedCoerce = do+    v <- asks tcCollectedCoerce+    r <- liftIO $ readIORef v+    r <- T.mapM flattenType r+    return r++runTc :: (MonadIO m,OptionMonad m) => TcInfo -> Tc a -> m a+runTc tcInfo  (Tc tim) = do+    opt <- getOptions+    liftIO $ do+    vn <- newIORef 0+    ce <- newIORef mempty+    cc <- newIORef mempty+    (a,out) <- runWriterT $ runReaderT tim TcEnv {+        tcCollectedEnv    = ce,+        tcCollectedCoerce = cc,+        tcConcreteEnv     = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,+        tcMutableEnv      = mempty,+        tcVarnum          = vn,+        tcDiagnostics     = [Msg Nothing $+            "Compilation of module: " ++ show (tcInfoModName tcInfo)],+        tcInfo            = tcInfo,+        tcRecursiveCalls  = mempty,+        tcInstanceEnv     = makeInstanceEnv (tcInfoClassHierarchy tcInfo),+        tcCurrentScope    = mempty,+        tcOptions         = opt+        }+    liftIO $ processErrors (T.toList $ tcWarnings out)+    return a++instance OptionMonad Tc where+    getOptions = asks tcOptions++-- | given a diagnostic and a computation to take place inside the TI-monad,+--   run the computation but during it have the diagnostic at the top of the+--   stack++withContext :: Diagnostic -> Tc a -> Tc a+withContext diagnostic comp = do+    local (tcDiagnostics_u (diagnostic:)) comp++addRule :: Rule -> Tc ()+addRule r = tell mempty { checkedRules = Seq.singleton r }++getErrorContext :: Tc [Diagnostic]+getErrorContext = asks tcDiagnostics++getClassHierarchy  :: Tc ClassHierarchy+getClassHierarchy = asks (tcInfoClassHierarchy . tcInfo)++getKindEnv :: Tc KindEnv+getKindEnv = asks (tcInfoKindInfo . tcInfo)++getSigEnv :: Tc TypeEnv+getSigEnv = asks (tcInfoSigEnv . tcInfo)++askCurrentEnv = do+    env1 <- asks tcConcreteEnv+    env2 <- asks tcMutableEnv+    return (env2 `Map.union` env1)++{-+dConScheme :: Name -> Tc Sigma+dConScheme conName = do+    env <- askCurrentEnv+    case Map.lookup conName env of+        Just s -> return s+        Nothing -> error $ "dConScheme: constructor not found: " ++ show conName +++                              "\nin this environment:\n" ++ show env+-}++-- | returns a new box and a function to read said box.++newBox :: Kind -> Tc Type+newBox k = newMetaVar Sigma k++unificationError t1 t2 = do+    t1 <- evalFullType t1+    t2 <- evalFullType t2+    diagnosis <- getErrorContext+    let Left msg = typeError (Unification $ "attempted to unify " +++            prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis+    liftIO $ processIOErrors+    liftIO $ putErrLn msg+    liftIO $ exitFailure++lookupName :: Name -> Tc Sigma+lookupName n = do+    env <- askCurrentEnv+    case Map.lookup n env of+        Just x -> freshSigma x+        Nothing | Just 0 <- fromUnboxedNameTuple n  -> do+            return (tTTuple' [])+        Nothing | Just num <- fromUnboxedNameTuple n -> do+            nvs <- mapM newVar  (replicate num kindArg)+            let nvs' = map TVar nvs+            return (TForAll nvs $ [] :=> foldr TArrow  (tTTuple' nvs') nvs')+        Nothing -> fail $ "Could not find var in tcEnv:" ++ show (nameType n,n)++newMetaVar :: MetaVarType -> Kind -> Tc Type+newMetaVar t k = do+    te <- ask+    n <- newUniq+    r <- liftIO $ newIORef Nothing+    return $ TMetaVar MetaVar { metaUniq = n, metaKind = k, metaRef = r, metaType = t }++class Instantiate a where+    inst:: Map.Map Int Type -> Map.Map Name Type -> a -> a++instance Instantiate Type where+    inst mm ts (TAp l r)     = tAp (inst mm ts l) (inst mm ts r)+    inst mm ts (TArrow l r)  = TArrow (inst mm ts l) (inst mm ts r)+    inst mm  _ t@TCon {}     = t+    inst mm ts (TVar tv ) = case Map.lookup (tyvarName tv) ts of+            Just t'  -> t'+            Nothing -> (TVar tv)+    inst mm ts (TForAll as qt) = TForAll as (inst mm (foldr Map.delete ts (map tyvarName as)) qt)+    inst mm ts (TExists as qt) = TExists as (inst mm (foldr Map.delete ts (map tyvarName as)) qt)+    inst mm ts (TMetaVar mv) | Just t <- Map.lookup (metaUniq mv) mm  = t+    inst mm ts (TMetaVar mv) = TMetaVar mv+    inst mm ts (TAssoc tc as bs) = TAssoc tc (map (inst mm ts) as) (map (inst mm ts) bs)+    --inst mm _ t = error $ "inst: " ++ show t++instance Instantiate a => Instantiate [a] where+  inst mm ts = map (inst mm ts)++instance Instantiate t => Instantiate (Qual t) where+  inst mm ts (ps :=> t) = inst mm ts ps :=> inst mm ts t++instance Instantiate Pred where+  inst mm ts is = tickle (inst mm ts :: Type -> Type) is++freshInstance :: MetaVarType -> Sigma -> Tc ([Type],Rho)+freshInstance typ (TForAll as qt) = do+    ts <- mapM (newMetaVar typ) (map tyvarKind as)+    let (ps :=> t) = (applyTyvarMapQT (zip as ts) qt)+    addPreds ps+    return (ts,t)+freshInstance _ x = return ([],x)++addPreds :: Preds -> Tc ()+addPreds ps = do+    sl <- getSrcLoc+    Tc $ tell mempty { collectedPreds = [ p | p@IsIn {} <- ps ],+        constraints = Seq.fromList [ Equality { constraintSrcLoc = sl,+        constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] }++--addConstraints :: [Constraint] -> Tc ()+--addConstraints ps = Tc $ tell mempty { constraints = Seq.fromList ps }++listenPreds :: Tc a -> Tc (a,Preds)+listenPreds action = censor (\x -> x { collectedPreds = mempty }) $+    listens collectedPreds action++listenCPreds :: Tc a -> Tc (a,(Preds,[Constraint]))+listenCPreds action = censor (\x -> x { constraints = mempty, collectedPreds = mempty }) $+    listens (\x -> (collectedPreds x,T.toList $ constraints x)) action++listenCheckedRules :: Tc a -> Tc (a,[Rule])+listenCheckedRules action = do+    (a,r) <- censor (\x -> x { checkedRules = mempty }) $ listens checkedRules action+    return (a,T.toList r)++newVar :: Kind -> Tc Tyvar+newVar k = do+    te <- ask+    n <- newUniq+    let ident = toName TypeVal (tcInfoModName $ tcInfo te,'v':show n)+        v = tyvar ident k+    return v++-- rename the bound variables of a sigma, just in case.+freshSigma :: Sigma -> Tc Sigma+freshSigma (TForAll [] ([] :=> t)) = return t+freshSigma (TForAll vs qt) = do+    nvs <- mapM (newVar . tyvarKind) vs+    return (TForAll nvs $ applyTyvarMapQT (zip vs (map TVar nvs)) qt)+freshSigma x = return x++toSigma :: Sigma -> Sigma+toSigma t@TForAll {} = t+toSigma t = TForAll [] ([] :=> t)++-- | replace bound variables with arbitrary new ones and drop the binding+-- TODO predicates?++skolomize :: Sigma -> Tc ([Tyvar],[Pred],Type)+skolomize s = freshSigma s >>= return . fromType++boxyInstantiate :: Sigma -> Tc ([Type],Rho')+boxyInstantiate = freshInstance Sigma++deconstructorInstantiate :: Sigma -> Tc Rho'+deconstructorInstantiate tfa@TForAll {} = do+    TForAll vs qt@(_ :=> t) <- freshSigma tfa+    let f (_ `TArrow` b) = f b+        f b = b+        eqvs = vs Data.List.\\ freeVars (f t)+    tell mempty { existentialVars = eqvs }+    (_,t) <- freshInstance Sigma (TForAll (vs Data.List.\\ eqvs) qt)+    return t+deconstructorInstantiate x = return x++boxySpec :: Sigma -> Tc ([(BoundTV,[Sigma'])],Rho')+boxySpec (TForAll as qt@(ps :=> t)) = do+    let f (TVar t) vs | t `elem` vs = do+            b <- lift (newBox $ tyvarKind t)+            tell [(t,b)]+            return b+        f e@TCon {} _ = return e+        f (TAp a b) vs = liftM2 tAp (f a vs) (f b vs)+        f (TArrow a b) vs = liftM2 TArrow (f a vs) (f b vs)+        f (TForAll as (ps :=> t)) vs = do+            t' <- f t (vs Data.List.\\ as)+            return (TForAll as (ps :=> t'))+        f t _ = return t+        -- f t _ = error $ "boxySpec: " ++ show t+    (t',vs) <- runWriterT (f t as)+    addPreds $ inst mempty (Map.fromList [ (tyvarName bt,s) | (bt,s) <- vs ]) ps+    return (sortGroupUnderFG fst snd vs,t')+boxySpec _ = error "boxySpec: bad."++freeMetaVarsEnv :: Tc (Set.Set MetaVar)+freeMetaVarsEnv = do+    env <- asks tcMutableEnv+    xs <- flip mapM (Map.elems env)  $ \ x -> do+        x <- flattenType x+        return $ freeMetaVars x+    return (Set.unions xs)++quantify_n :: [MetaVar] -> [Pred] -> [Rho] -> Tc [Sigma]+quantify_n vs ps rs | not $ any isBoxyMetaVar vs = do+    -- we bind the quantified variables to fresh tvars+    vs <- mapM groundKind vs+    nvs <- mapM (newVar . fixKind . metaKind) vs+    sequence_ [ varBind mv (TVar v) | v <- nvs |  mv <- vs ]++    ps <- flattenType ps+    rs <- flattenType rs++    ch <- getClassHierarchy+    return $ [TForAll nvs (FrontEnd.Tc.Class.simplify ch ps :=> r) | r <- rs ]+                    | otherwise = error "quantify_n: bad."++quantify :: [MetaVar] -> [Pred] -> Rho -> Tc Sigma+quantify vs ps r = do [s] <- quantify_n vs ps [r]; return s++-- turn all ?? into * types, as we can't abstract over unboxed types+fixKind :: Kind -> Kind+fixKind (KBase KQuestQuest) = KBase Star+fixKind (KBase KQuest) = KBase Star+fixKind (a `Kfun` b) = fixKind a `Kfun` fixKind b+fixKind x = x++groundKind mv = zonkKind (fixKind $ metaKind mv) mv++-- this removes all boxes, replacing them with tau vars+unBox ::  Type -> Tc Type+unBox tv = ft' tv where+    ft t@(TMetaVar mv)+        | isBoxyMetaVar mv = do+            tmv <- newMetaVar Tau (getType mv)+            varBind mv tmv+            return tmv+        | otherwise =  return t+    ft t = tickleM ft' t+    ft' t = evalType t >>= ft++evalType t = findType t >>= evalTAssoc >>= evalArrowApp+evalFullType t = f' t where+    f t = tickleM f' t+    f' t =  evalType t >>= f++evalTAssoc ta@TAssoc { typeCon = Tycon { tyconName = n1 }, typeClassArgs = ~[carg], typeExtraArgs = eas }  = do+    carg' <- evalType carg+    case fromTAp carg' of+        (TCon Tycon { tyconName = n2 }, as) -> do+            InstanceEnv ie <- asks tcInstanceEnv+            case Map.lookup (n1,n2) ie of+                Just (aa,bb,tt) -> evalType (applyTyvarMap (zip aa as ++ zip bb eas) tt)+                _ -> fail "no instance for associated type"+        _ -> return ta { typeClassArgs = [carg'] }+evalTAssoc t = return t++evalArrowApp (TAp (TAp (TCon tcon) ta) tb)+    | tyconName tcon == tc_Arrow = return (TArrow ta tb)++evalArrowApp t = return t++-- Bind mv to type, first filling in any boxes in type with tau vars+varBind :: MetaVar -> Type -> Tc ()+varBind u t+--    | getType u /= getType t = error $ "varBind: kinds do not match:" ++ show (u,t)+    | otherwise = do+        kindCombine (getType u) (getType t)+        tt <- unBox t+        --(t,be,_) <- unbox t+        --when be $ error $ "binding boxy: " ++ tupled [pprint u,prettyPrintType t]+        tt <- evalFullType tt+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "varBind: " ++ pprint u <+>+            text ":=" <+> prettyPrintType tt+        when (u `Set.member` freeMetaVars tt) $ do+            unificationError (TMetaVar u) tt -- occurs check+        let r = metaRef u+        x <- liftIO $ readIORef r+        case x of+            Just r -> fail $ "varBind: binding unfree: " +++                tupled [pprint u,prettyPrintType tt,prettyPrintType r]+            Nothing -> liftIO $ do+                --when (dump FD.BoxySteps) $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType t+                writeIORef r (Just tt)++zonkKind :: Kind -> MetaVar -> Tc MetaVar+zonkKind nk mv = do+    fk <- kindCombine nk (metaKind mv)+    if fk == metaKind mv then return mv else do+        nref <- liftIO $ newIORef Nothing+        let nmv = mv { metaKind = fk, metaRef = nref }+        liftIO $ modifyIORef (metaRef mv) (\Nothing -> Just $ TMetaVar nmv)+        return nmv++zonkBox :: MetaVar -> Tc Type+zonkBox mv | isBoxyMetaVar mv = findType (TMetaVar mv)+zonkBox mv = fail $ "zonkBox: nonboxy" ++ show mv++readFilledBox :: MetaVar -> Tc Type+readFilledBox mv | isBoxyMetaVar mv = zonkBox mv >>= \v -> case v of+    TMetaVar mv' | mv == mv' -> fail $ "readFilledBox: " ++ show mv+    t -> return t+readFilledBox mv = error $ "readFilledBox: nonboxy" ++ show mv++{-+elimBox :: MetaVar -> Tc Type+elimBox mv | isBoxyMetaVar mv = do+    t <- readMetaVar mv+    case t of+        Just t -> return t+        Nothing -> newMetaVar Tau (getType mv)++elimBox mv = error $ "elimBox: nonboxy" ++ show mv+-}++----------------------------------------+-- Declaration of instances, boilerplate+----------------------------------------++--pretty :: PPrint Doc a => a -> String+--pretty x = show (pprint x :: Doc)++instance Monad Tc where+    return a = Tc $ return a+    Tc comp >>= fun = Tc $ do x <- comp; case fun x of Tc m -> m+    Tc a >> Tc b = Tc $ a >> b+    fail s = Tc $ do+        st <- ask+        liftIO $ processIOErrors+        Left x <- typeError (Failure s) (tcDiagnostics st)+        liftIO $ fail x++instance MonadWarn Tc where+    addWarning w = tell mempty { tcWarnings = Seq.singleton w }++instance MonadSrcLoc Tc where+    getSrcLoc = do+        xs <- asks tcDiagnostics+        case xs of+            (Msg (Just sl) _:_) -> return sl+            _ -> return bogusASrcLoc++instance UniqueProducer Tc where+    newUniq = do+        v <- asks tcVarnum+        n <- liftIO $ do+            n <- readIORef v+            writeIORef v $! n + 1+            return n+        return n++tcInfoEmpty = TcInfo {+    tcInfoEnv            = mempty,+    tcInfoModName        = toModule "(unknown)",+    tcInfoKindInfo       = mempty,+    tcInfoClassHierarchy = mempty,+    tcInfoSigEnv         = mempty+}++withMetaVars :: MetaVar -> [Kind] -> ([Sigma] -> Sigma) -> ([Sigma'] -> Tc a) -> Tc a+withMetaVars mv ks sfunc bsfunc | isBoxyMetaVar mv = do+    boxes <- mapM newBox ks+    res <- bsfunc boxes+    tys <- mapM readFilledBox [ mv | ~(TMetaVar mv) <- boxes]+    varBind mv (sfunc tys)+    return res+withMetaVars mv ks sfunc bsfunc  = do+    taus <- mapM (newMetaVar Tau) ks+    varBind mv (sfunc taus)+    bsfunc taus+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Monoid Output where+    mempty = Output mempty mempty mempty mempty mempty mempty mempty+    mappend (Output aa ab ac ad ae af ag) (Output aa' ab' ac' ad' ae' af' ag') = Output (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')(mappend af af')(mappend ag ag')++--  Imported from other files :-
+ drift_processed/Grin/SSimplify.hs view
@@ -0,0 +1,443 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/Grin/SSimplify.hs" #-}+module Grin.SSimplify(simplify,explicitRecurse) where++import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Data.Maybe+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as Map+import qualified Data.Set as Set++import Grin.Grin+import Grin.Noodle+import Stats(mtick)+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Support.Tickle+import Util.GMap+import Util.Gen+import Util.HasSize+import Util.RWS+import Util.SetLike+import qualified Stats++-- This goes through and puts grin into a normal form, in addition, it carries out some straightforward+-- simplifications.+--+-- normalized form has the following properties+--+-- :>>= only appears in trailing position+-- Return [v0 .. vn] for n > 1 only appears in trailing position+--+-- all variables and function names are unique in their scope.++data SEnv = SEnv {+    envSubst :: IM.IntMap Val,   -- renaming substitution+    envCSE   :: Map.Map Exp (Atom,Exp),+    envPapp  :: IM.IntMap (Atom,[Val])+    --envPush  :: IM.IntMap Exp+    }+    {-! derive: Monoid !-}++newtype SState = SState { usedVars :: IS.IntSet }++data SCol = SCol {+    colStats :: Stats.Stat,+    colFreeVars :: GSet Var+    }+    {-! derive: Monoid !-}++{-+data ExpInfo = ExpInfo {+    expFreeVars :: GSet Var,+    expUnboxing :: UnboxingResult,+    expType     :: [Ty]+    }+-}++newtype S a = S (RWS SEnv SCol SState a)+    deriving(Monad,Functor,MonadWriter SCol, MonadReader SEnv,MonadState SState)++instance Stats.MonadStats S where+    mtickStat s = S (tell mempty { colStats = s })+    mticks' n a = S (tell mempty { colStats = Stats.singleStat n a })++tellFV v = tell mempty { colFreeVars = freeVars v }++simplify :: Grin -> IO Grin+simplify grin = do+    let (fs,_,SCol { colStats = stats}) = runRWS fun mempty SState { usedVars = mempty }+        S fun = simpFuncs (grinFunctions grin)+    return grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats }++simpFuncs :: [FuncDef] -> S [FuncDef]+simpFuncs fd = do+    let f fd@FuncDef { funcDefBody = body } = do+            body' <- simpLam body+            return $ updateFuncDefProps fd { funcDefBody = body' }+    mapM f fd++simpLam :: Lam -> S Lam+simpLam (ps :-> e) = do+    (ps,env') <- renamePattern ps+    let f col = col { colFreeVars = colFreeVars col \\ freeVars ps }+    (e,col) <- censor f $ listen $ local (env' `mappend`) $ simpExp e+    ps <- mapM (zeroVars (`member` colFreeVars col)) ps+    return (ps :-> e)++dstore x = BaseOp (StoreNode True) [x]++simpDone :: Exp -> S Exp+simpDone e = do+    pmap <- asks envPapp+    case e of+        (BaseOp (Apply ty) (Var (V vn) _:fs)) | Just (tl,gs) <- IM.lookup vn pmap -> do+            (cl,fn) <- tagUnfunction tl+            mtick $ if cl == 1 then "Simplify.Apply.Papp.{" ++ show tl  else ("Simplify.Apply.App.{" ++ show fn)+            return $ if cl == 1+                then App fn (gs ++ fs) ty+                else dstore (NodeC (partialTag fn (cl - 1)) (gs ++ fs))+        (Case v ls) | isJust utypes -> ans where+            utypes@(~(Just ts)) = unboxTypes ur+            ur = foldr1 combineUnboxing [ getUnboxing e | _ :-> e <- ls ]+            ans = do+                mtick "Grin.Simplify.Unbox.case-return"+                let vs = zipWith Var [v1 ..] ts+                return (unboxModify ur (Case v ls) :>>= vs :->  (unboxRet ur vs))+        (Case v1 ls) | [v1'] :-> Case v2 ls' <- last ls, v1' == v2 || v1 == v2 -> do+            let f (p :-> e) = p :-> Return [v1] :>>= [v1'] :-> e+            mtick "Grin.Simplify.case-merge"+            return $ Case v1 (init ls ++ map f ls')+        --(e :>>= p :-> Return p') | p == p' -> do+        --    mtick "Grin.Simplify.tail-return-omit"+        --    return e+        _ -> do+            cmap <- asks envCSE+            case Map.lookup e cmap of+                Just (n,e') -> do mtick n; tellFV e'; return e'+                Nothing -> return e++simpBind :: [Val] -> Exp -> S Exp -> S Exp+simpBind p e cont = f p e where+    cse name xs = do+        (z,col) <- listen $ local (\s -> s { envCSE = Map.fromList [ (x,(toAtom name,y)) | (x,y) <- xs] `Map.union` envCSE s }) cont+        e <- simpDone e+        if isOmittable e && isEmpty (freeVars p `intersection` colFreeVars col) then do+            mtick "Simplify.Omit.Bind"+            return z+         else return $ e :>>= (p :-> z)+    cse' name xs = cse name ((e,Return p):xs)+    f p app@(BaseOp Eval [v]) =  cse' "Simplify.CSE.eval" [(BaseOp Promote [v],Return p)]+    f p (BaseOp Promote [v@Var {}]) =  cse' "Simplify.CSE.promote" [(gEval v,Return p)]+    f [p] (BaseOp Demote [v@Var {}]) =  cse' "Simplify.CSE.demote" [(BaseOp Promote [p],Return [v]),(gEval p,Return [v])]+    f [p@(Var (V vn) _)] (BaseOp (StoreNode isD) [v@(NodeC t vs)]) | not (isHoly v) = case (isD,tagUnfunction t,tagIsWHNF t) of+        (True,Nothing,_) -> cse' "Simplify.CSE.return-node" []+        (True,Just (n,fn),_) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node-func" []+        --(False,_,True)  -> local (\s -> s { envPush = IM.insert vn (Store v) (envPush s) }) $ cse "Simplify.CSE.store-whnf" []+        --(False,_,False) -> cse' "Simplify.CSE.store" []+        _ -> cse' "Simplify.CSE.store" []+--    f [p@(Var (V vn) _)] (Return [v@(NodeC t vs)]) | not (isHoly v) = case tagUnfunction t of+--        Nothing -> cse "Simplify.CSE.return-node" [(Return [p],Return [v]),(Store p,Store v)]+--        Just (n,fn) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node" [(Return [p],Return [v]),(Store p,Store v)]+--    f [p@(Var (V vn) _)] (Store v@(NodeC t vs)) | not (isHoly v) = case tagIsWHNF t of+--        True -> local (\s -> s { envPush = IM.insert vn (Store v) (envPush s) }) $ cse "Simplify.CSE.store-whnf" [(BaseOp Promote [p],Return [v]),(gEval p,Return [v])]+--        False -> cse' "Simplify.CSE.store" []+    f _ _ = cse "Simplify.CSE.NOT" []++extEnv :: Var -> Val -> SEnv -> SEnv+extEnv (V vn) v s = s { envSubst = IM.insert vn v (envSubst s) }++simpExp :: Exp -> S Exp+simpExp e = f e [] where+    f (e :>>= p :-> Return p') rs | p == p' = do+        mtick "Grin.Simplify.tail-return-omit"+        f e rs+    f  (a :>>= (v :-> b)) xs = do+        env <- ask+        f a ((env,v,b):xs)++    -- simple transforms+    f (BaseOp Promote [Const x]) rs = do+        mtick "Grin.Simplify.fetch-const"+        f (Return [x]) rs+--    f (Store x) rs | valIsNF x = do+--        mtick "Grin.Simplify.store-normalform"+--        f (Return [Const x]) rs+    f (BaseOp Eval [Const n]) rs = do+        mtick "Grin.Simplify.eval-const"+        f (Return [n]) rs+    f (Error s t) rs@(_:_) = do+        mtick "Grin.Simplify.error-discard"+        let (_,_,b) = last rs+        f (Error s (getType b)) []+    f (Return [v]) ((senv,[Var vn _],b):rs) | valIsConstant v = do+        mtick "Grin.Simplify.Subst.const"+        fbind vn v senv b rs+    f (Return [v@ValUnknown {}]) ((senv,[Var vn _],b):rs) = do+        mtick "Grin.Simplify.Subst.unknown"+        fbind vn v senv b rs+    f (Return [v@Var {}]) ((senv,[Var vn _],b):rs) = do+        mtick "Grin.Simplify.Subst.var"+        fbind vn v senv b rs+--    f a@(Return [NodeC t xs]) ((senv,[NodeC t' ys],b):rs) | t == t' = do+--        mtick "Grin.Simplify.Assign.node-node"+--        dtup xs ys senv b rs+    f (Return []) ((senv,[],b):rs) = do+        mtick "Grin.Simplify.Assign.unit-unit"+        dtup [] [] senv b rs+    f a@(Return (xs@(_:_:_))) ((senv,ys,b):rs) = do+        mtick "Grin.Simplify.Assign.tuple-tuple"+        dtup xs ys senv b rs+    f (Case v@Var {} [l]) rs = do+        f (Return [v] :>>= l) rs+--    f e@(Case v ls) rs | isJust utypes  = ans where+--        utypes@(~(Just ts)) = unboxTypes ur+--        ur = foldr1 combineUnboxing [ getUnboxing e | _ :-> e <- ls ]+--        ans = do+--            mtick "Grin.Simplify.Unbox.case-return"+--            let vs = zipWith Var [v1 ..] ts+--            f (unboxModify ur (Case v ls) :>>= vs :-> Return (unboxRet ur vs)) rs+    f a ((senv,p,b):xs) = do+        a <- g a+        (p,env') <- renamePattern p+        let env'' = env' `mappend` senv+        local (const env'') $ simpBind p a (f b xs)+    f x [] = do+        e <- g x+        simpDone e+    fbind vn v senv b rs = do+        v' <- applySubst v+        local (\_ -> extEnv vn v' senv) $ f b rs++    dtup xs ys senv b rs | sameLength xs ys = do+        xs <- mapM applySubst xs+        (ys,env') <- renamePattern ys+        let env'' = env' `mappend` senv+        z <- local (const env'') $ f b rs+        ts <- mapM (return . Just) [([y],Return [x]) | x <- xs | y <- ys ]+        let h [] = z+            h ((p,v):rs) = v :>>= p :-> h rs+        return $ h [ (p,v) |  Just (p,v) <- ts]+    dtup _ _ _ _ _ = error "dtup: attempt to bind unequal lists"+    g (Case v as) = do+        v <- applySubst v+        as <- mapM simpLam as+        return $ Case v as+    g  lt@Let { expDefs = defs, expBody = body } = do+        body <- f body []+        defs <- simpFuncs defs+        let dnames = fromList $ map funcDefName defs :: GSet Atom+            isInvalid e = isEmpty (freeVars e `intersection` dnames)+        case body of+            e :>>= l :-> r | isInvalid e -> do+                mtick "Simplify.simplify.let-shrink-head"+                return $ e :>>= l :-> updateLetProps lt { expBody = r, expDefs = defs }+            e :>>= l :-> r | isInvalid r -> do+                mtick "Simplify.simplify.let-shrink-tail"+                return (updateLetProps lt { expBody = e, expDefs = defs } :>>= l :-> r)+            App f as ts | f `elem` map funcDefName defs, f `Set.notMember` freeVars (map funcDefBody defs) -> do+                mtick "Simplify.simplify.let-inline-body"+                let [fbody] = [ funcDefBody fd | fd <- defs, funcDefName fd == f]+                return $ updateLetProps lt { expDefs = defs, expBody = Return as :>>= fbody }+            _ -> return $ updateLetProps lt { expBody = body, expDefs = defs }+    g x = applySubstE x++applySubstE :: Exp -> S Exp+applySubstE x = mapExpVal applySubst x++applySubst x = f x where+    f var@(Var (V v) _) = do+        env <- asks envSubst+        case IM.lookup v env of+            Just n -> tellFV n >> return n+            Nothing -> tellFV var >> return var+    f x = mapValVal f x++zeroVars fn x = f x where+    f (Var v ty) | fn v || v == v0 = return (Var v ty)+                 | otherwise = do mtick $ "Simplify.ZeroVar.{" ++ show (Var v ty); return (Var v0 ty)+    f x = mapValVal f x++renamePattern :: [Val] ->  S ([Val],SEnv)+renamePattern x = runWriterT (mapM f x) where+    f :: Val -> WriterT SEnv S Val+    f (Var v@(V vn) t) = do+        v' <- lift $ newVarName v+        let nv = Var v' t+        tell (mempty { envSubst = IM.singleton vn nv })+        return nv+    f x = mapValVal f x++newVarName :: Var -> S Var+newVarName (V 0) = return (V 0)+newVarName (V sv) = do+    s <- gets usedVars+    let nv = v sv+        v n | n `IS.member` s = v (1 + n + IS.size s)+            | otherwise = n+    modify (\e -> e { usedVars = IS.insert nv s })+    return (V nv)++isHoly (NodeC _ as) | any isValUnknown as = True+isHoly n = False++data UnboxingResult+    = UnErr [Ty]+    | UnStore !Bool !Atom [Unbox]+    | UnDemote Unbox+    | UnReturn [Unbox]+    | UnTail (Set.Set Atom) [Ty] [Ty]++data Unbox =  UnConst Val | UnUnknown Ty | UnBaseOp BaseOp [Unbox]+    deriving(Eq,Ord)++isUnUnknown UnUnknown  {} = True+isUnUnknown _ = False++instance CanType UnboxingResult where+    type TypeOf UnboxingResult = [Ty]+    getType (UnErr tys) = tys+    getType (UnReturn us) = map getType us+    getType (UnStore b _ _) = [bool b tyDNode tyINode]+    getType (UnDemote _) = [tyINode]+    getType (UnTail _ tys _) = tys++instance CanType Unbox where+    type TypeOf Unbox = Ty+    getType (UnConst v) = getType v+    getType (UnUnknown t) = t+    getType _ = error "getType: bad."++unboxRet :: UnboxingResult -> [Val] -> Exp+unboxRet ur vs = f ur vs where+    f (UnReturn xs) vs = Return $ let (r,[]) = g xs vs in r+    f (UnStore b c xs) vs = let (xs',[]) = g xs vs in BaseOp (StoreNode b) [NodeC c xs']+    f (UnDemote u) vs = let ([u'],[]) = g [u] vs in BaseOp Demote [u']+    f (UnTail a _ tys) vs | [f] <- Set.toList a = App f vs tys+    f UnErr {} _ = Return []+    f _ vs = Return vs+    g [] vs = ([],vs)+    g (UnUnknown _:xs) (v:vs) = let (r,y) = g xs vs in (v:r,y)+    g (UnConst v:xs) vs = let (r,y) = g xs vs in (v:r,y)+    g _ _ = error "SSimplify.unboxRet: bad."++unboxTypes :: UnboxingResult -> Maybe [Ty]+unboxTypes ur = f ur where+    f (UnTail ts tys _) | Set.size ts == 1 = Just tys+    f (UnTail {}) = Nothing+    f (UnErr []) = Nothing+    f (UnErr (_:_)) = Just []+    f (UnReturn us) | all isUnUnknown us = Nothing+    f (UnReturn xs) = Just $ concatMap h xs+    f (UnStore _ _ ts) = Just $ concatMap h ts+    f (UnDemote _) = Just [tyDNode]+    h (UnUnknown t) = [t]+    h (UnConst {}) = []+    h _ = error "SSimplify.unboxTypes: bad."++unboxModify :: UnboxingResult -> Exp -> Exp+unboxModify ur = f ur where+    Just nty = unboxTypes ur+    f UnErr {} = id+    f (UnTail a tys _) | [f] <- Set.toList a = runIdentity . editTail tys (mApp f)+    f (UnReturn us) | all isUnUnknown us = id+    f (UnReturn xs) = runIdentity . editTail nty (g xs)+    f (UnStore _ _ us) =runIdentity . editTail nty (z us)+    f (UnDemote _) =runIdentity . editTail nty y+    f _ = error "SSimplify.unboxModify: bad1."+    g xs (Return ys) = return $ Return (concat $ zipWith h xs ys)+    g _ _ = error "SSimplify.unboxModify: bad2."+    h (UnUnknown _) y = [y]+    h (UnConst {}) _ = []+    h _ _ = error "SSimplify.unboxModify: bad3."+    z xs (BaseOp (StoreNode _) [NodeC _ ts]) = return . Return . concat $ zipWith h xs ts+    z _ _ = error "SSimplify.unboxModify: bad4."+    y (BaseOp Demote [x]) = return $ Return [x]+    y (Return [Const v]) = return $ Return [v]+    y _ = error "SSimplify.unboxModify: bad5."+    mApp f (App f' as tys) | f == f' = return $ Return as+    mApp f e  = error $ "mApp: " ++ show (f,e)++combineUnboxing :: UnboxingResult -> UnboxingResult -> UnboxingResult+combineUnboxing ub1 ub2 = f ub1 ub2 where+    f UnErr {} x = x+    f x UnErr {} = x+    f (UnTail t1 a1 u1) (UnTail t2 a2 u2) | u1 == u2, a1 == a2 = UnTail (t1 `union` t2) a1 u1+    f (UnReturn xs) (UnReturn ys) = UnReturn (zipWith g xs ys)+    f (UnStore b1 a1 xs1) (UnStore b2 a2 xs2) | a1 == a2 = UnStore b1 a1 (zipWith g xs1 xs2)+                                              | otherwise = UnReturn [UnUnknown (bool b1 tyDNode tyINode)]+    f (UnDemote u1) (UnDemote u2) = UnDemote (g u1 u2)+    f (UnDemote u1) (UnReturn [UnConst (Const v)]) = UnDemote (UnUnknown tyDNode)+    f (UnReturn [UnConst (Const v)]) (UnDemote u1) = UnDemote (UnUnknown tyDNode)+    f x _ = UnReturn (map UnUnknown (getType x))+    g (UnConst v1) (UnConst v2) | v1 == v2 = UnConst v1+                                | otherwise = UnUnknown (getType v1)+    g x _ = UnUnknown (getType x)++getUnboxing :: Exp -> UnboxingResult+getUnboxing e = f e where+    f (Return rs) = UnReturn (map g rs)+    f (BaseOp (StoreNode b) [NodeC c xs]) = UnStore b c (map g xs)+    f (BaseOp Demote [v]) = UnDemote (g v)+    f (Error _ tys) = UnErr tys+    f (App f vs ts) = UnTail (singleton f) (getType vs) ts+    f (Case _ ls) = foldr1 combineUnboxing  [ f e | _ :-> e <- ls ]+    f Let { expDefs = defs, expBody = body, expIsNormal = False } = case f body of+        UnTail fs _ ntys | not $ Set.null (fs `Set.intersection` (Set.fromList $ map funcDefName defs)) -> UnReturn (map UnUnknown ntys)+        e -> e+    f (_ :>>= _ :-> e) = f e+    f e = UnReturn (map UnUnknown $ getType e)+    g v | valIsConstant v = UnConst v+    g v = UnUnknown (getType v)++editTail :: Monad m => [Ty] -> (Exp -> m Exp) -> Exp -> m Exp+editTail nty mt te = f (sempty :: GSet Atom) te where+    f _ (Error s ty) = return $ Error s nty+    f lf (Case x ls) = return (Case x) `ap` mapM (g lf) ls+    f lf lt@Let {expIsNormal = False, expBody = body } = do+        body <- f lf body+        return $ updateLetProps lt { expBody = body }+    f lf lt@Let {expDefs = defs, expIsNormal = True } = do+        let nlf = lf `union` fromList (map funcDefName defs)+        mapExpExp (f nlf) lt+    f lf lt@MkCont {expLam = lam, expCont = cont } = do+        a <- g lf lam+        b <- g lf cont+        return $ lt { expLam = a, expCont = b }+    f lf (e1 :>>= p :-> e2) = do+        e2 <- f lf e2+        return $ e1 :>>= p :-> e2+    f lf e@(App a as t) | a `member` lf = return $ App a as nty+    f lf e = mt e+    g lf (p :-> e) = do e <- f lf e; return $ p :-> e++bool b x y = if b then x else y++-- this finds top level functions that call themselves recursively and turns the recursive call into a+-- local definition, allowing it to be compiled to a direct loop.++explicitRecurse+    :: Grin+    -> IO Grin+explicitRecurse grin =  mapGrinFuncsM f grin where+    f name lam | name `notMember` (freeVars lam :: GSet Atom) = return lam+    f name (as :-> e) = do+        let nname = toAtom $ "bR" ++ fromAtom name+            g (App n rs t) | n == name = App nname rs t+            g e = tickle g e+        return $ as :-> grinLet [createFuncDef True nname (as :-> g e) ] (App nname as (getType e))+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Monoid SEnv where+    mempty = SEnv mempty mempty mempty+    mappend (SEnv aa ab ac) (SEnv aa' ab' ac') = SEnv (mappend aa aa')(mappend ab ab')(mappend ac ac')++instance Monoid SCol where+    mempty = SCol mempty mempty+    mappend (SCol aa ab) (SCol aa' ab') = SCol (mappend aa aa')(mappend ab ab')++--  Imported from other files :-
+ drift_processed/Ho/Build.hs view
@@ -0,0 +1,858 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/Ho/Build.hs" #-}+{-# LANGUAGE DoRec #-}+module Ho.Build (+    module Ho.Type,+    dumpHoFile,+    parseFiles,+    preprocess,+    preprocessHs,+    buildLibrary+    ) where++import Control.Concurrent+import Control.Monad.Identity+import Data.IORef+import Data.List hiding(union)+import Data.Maybe+import Data.Monoid(Monoid(..))+import Data.Tree+import Data.Version(Version,parseVersion,showVersion)+import System.FilePath as FP+import System.Mem+import Text.Printf+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.UTF8 as LBSU+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Text.PrettyPrint.HughesPJ as PPrint++import DataConstructors+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.E+import E.Rules+import E.Show+import E.Traverse(emapE)+import E.TypeCheck()+import FrontEnd.Class+import FrontEnd.FrontEnd+import FrontEnd.HsSyn+import FrontEnd.Infix+import FrontEnd.SrcLoc+import FrontEnd.Warning(warn,processIOErrors,WarnType(..))+import Ho.Binary+import Ho.Collected()+import Ho.Library+import Ho.ReadSource+import Ho.Type+import Name.Name+import Options+import PackedString(PackedString,packString,unpackPS)+import Support.TempDir+import Util.Gen+import Util.SetLike+import Util.YAML+import Version.Config(version)+import Version.Version(versionString)+import qualified FlagDump as FD+import qualified FlagOpts as FO+import qualified Support.MD5 as MD5+import qualified Util.Graph as G++-- Ho File Format+--+-- ho files are standard CFF format files (PNG-like) as described in the Support.CFF modules.+--+-- the CFF magic for the files is the string "JHC"+--+-- JHDR - header info, contains a list of modules contained and dependencies that need to be checked to read the file+-- LIBR - only present if this is a library, contains library metainfo+-- IDEP - immutable import information, needed to tell if ho files are up to date+-- LINK - redirect to another file for file systems without symlinks+-- DEFS - definitions type checking information+-- CORE - compiled core and associated data+-- LDEF - library map of module group name to DEFS+-- LCOR - library map of module group name to CORE+-- GRIN - compiled grin code+-- FILE - Extra file, such as embedded c code.++{-+ - We separate the data into various chunks for logical layout as well as the+ - important property that each chunk is individually compressed and accessable.+ - What this means is that we can skip chunks we don't need. for instance,+ - during the final link we have no need of the haskell type checking+ - information, we are only interested in the compiled code, so we can jump+ - directly to it. If we relied on straight serialization, we would have to+ - parse all preceding information just to discard it right away.  We also lay+ - them out so that we can generate error messages quickly. for instance, we can+ - determine if a symbol is undefined quickly, before it has to load the+ - typechecking data.+ -}++type LibraryName = PackedString++findFirstFile :: [FilePath] -> IO (LBS.ByteString,FilePath)+findFirstFile [] = fail "findFirstFile: file not found"+findFirstFile (x:xs) = flip iocatch (\e -> findFirstFile xs) $ do+    bs <- LBS.readFile x+    return (bs,x)++data ModDone+    = ModNotFound+    | ModLibrary !Bool ModuleGroup Library+    | Found SourceCode++data Done = Done {+    hoCache         :: Maybe FilePath,+    knownSourceMap  :: Map.Map SourceHash (Module,[(Module,SrcLoc)]),+    validSources    :: Set.Set SourceHash,+    loadedLibraries :: Map.Map LibraryName Library,+    hosEncountered  :: Map.Map HoHash     (FilePath,HoHeader,HoIDeps,Ho),+    modEncountered  :: Map.Map Module     ModDone+    }++hosEncountered_u f r@Done{hosEncountered  = x} = r{hosEncountered = f x}+knownSourceMap_u f r@Done{knownSourceMap  = x} = r{knownSourceMap = f x}+loadedLibraries_u f r@Done{loadedLibraries  = x} = r{loadedLibraries = f x}+modEncountered_u f r@Done{modEncountered  = x} = r{modEncountered = f x}+validSources_u f r@Done{validSources  = x} = r{validSources = f x}++replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix++hoFile :: Maybe FilePath -> FilePath -> Maybe Module -> SourceHash -> FilePath+hoFile cacheDir fp mm sh = case (cacheDir,optHoDir options) of+    (Nothing,Nothing) -> replaceSuffix "ho" fp+    (Nothing,Just hdir) -> case mm of+        Nothing -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho"+        Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where+            ft '/' = '.'+            ft x = x+    (Just hdir,_) -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho"++findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath)+findHoFile done_ref fp mm sh = do+    done <- readIORef done_ref+    let honame = hoFile (hoCache done) fp mm sh+    writeIORef done_ref (done { validSources = Set.insert sh (validSources done) })+    if sh `Set.member` validSources done || optIgnoreHo options then return (False,honame) else do+    onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) ->+        case hohHash hoh `Map.lookup` hosEncountered done of+            Just (fn,_,_,a) -> return (True,fn)+            Nothing -> do+                modifyIORef done_ref (knownSourceMap_u $ (`mappend` (hoIDeps hidep)))+                modifyIORef done_ref (validSources_u $ Set.union (Set.fromList . map snd $ hoDepends hidep))+                modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,hidep,ho))+                return (True,honame)++onErr :: IO a -> IO b -> (b -> IO a) -> IO a+onErr err good cont = join $ iocatch (good >>= return . cont) (\_ -> return err)++fetchSource :: Opt -> IORef Done -> [FilePath] -> Maybe (Module,SrcLoc) -> IO Module+fetchSource _ _ [] _ = fail "No files to load"+fetchSource modOpt done_ref fs mm = do+    let killMod = case mm of+            Nothing -> fail $ "Could not load file: " ++ show fs+            Just (m,sloc) -> do+                warn sloc (MissingModule m) $ printf "Module '%s' not found." (show m)+                modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m+    onErr killMod (findFirstFile fs) $ \ (lbs,fn) -> do+    let hash = MD5.md5lazy $ (LBSU.fromString version) `mappend` lbs+    (foundho,mho) <- findHoFile done_ref fn (fmap fst mm) hash+    done <- readIORef done_ref+    (mod,m,ds) <- case mlookup hash (knownSourceMap done) of+        Just (m,ds) -> return (Left lbs,m,ds)+        Nothing -> do+            (hmod,_) <- parseHsSource modOpt  fn lbs+            let m = hsModuleName hmod+                ds = hsModuleRequires hmod+            writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done)+            case optAnnotate options of+                Just _ -> return (Left lbs,m,ds)+                _ -> return (Right hmod,m,ds)+    case mm of+        Just (m',_) | m /= m' -> do+            putErrLn $ "Skipping file" <+> fn <+> "because its module declaration of" <+> show m <+> "does not equal the expected" <+> show m'+            killMod+        _ -> do+            let sc (Right mod) = SourceParsed sinfo mod+                sc (Left lbs) = SourceRaw sinfo lbs+                sinfo = SI { sourceHash = hash, sourceDeps = ds, sourceFP = fn, sourceHoName = mho, sourceModName = m }+            modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod)))+            fn' <- shortenPath fn+            mho' <- shortenPath mho+            putProgressLn $ if foundho+                then printf "%-23s [%s] <%s>" (show m) fn' mho'+                else printf "%-23s [%s]" (show m) fn'+            mapM_ (resolveDeps modOpt done_ref) ds+            return m++resolveDeps :: Opt -> IORef Done -> (Module,SrcLoc) -> IO ()+resolveDeps modOpt done_ref (m,sloc) = do+    done <- readIORef done_ref+    case m `mlookup` modEncountered done of+        Just (ModLibrary False _ lib) | not ("jhc-prim-" `isPrefixOf` libName lib) -> putErrDie $ printf  "ERROR: Attempt to import module '%s' which is a member of the library '%s'.\nPerhaps you need to add '-p%s' to the command line?" (show m) (libName lib) (libName lib)+        Just _ -> return ()+        Nothing -> fetchSource modOpt done_ref (map fst $ searchPaths modOpt (show m)) (Just (m,sloc)) >> return ()++type LibInfo = (Map.Map Module ModuleGroup, Map.Map ModuleGroup [ModuleGroup], Set.Set Module,Map.Map ModuleGroup HoBuild,Map.Map ModuleGroup HoTcInfo)++data CompNode = CompNode !HoHash [CompNode] {-# UNPACK #-} !(IORef CompLink)+data CompLink+    = CompLinkUnit CompUnit+    | CompCollected CollectedHo CompUnit+    | CompTcCollected HoTcInfo CompUnit+    | CompLinkLib (ModuleGroup,LibInfo) CompUnit++compLinkCompUnit (CompLinkUnit cu) = cu+compLinkCompUnit (CompCollected _ cu) = cu+compLinkCompUnit (CompTcCollected _ cu) = cu+compLinkCompUnit (CompLinkLib _ cu) = cu++instance MapKey Module where+    showMapKey = show+instance MapKey MD5.Hash where+    showMapKey = show++dumpDeps targets memap cug = case optDeps options of+    Nothing -> return ()+    Just fp -> do+        let (sfps,sdps,ls) = collectDeps memap cug+        let yaml = Map.fromList [+                ("Target",toNode targets),+                ("LibraryDesc",toNode [ fp | BuildHl fp  <- [optMode options]]),+                ("LibraryDeps",toNode ls),+                ("ModuleSource",toNode sfps),+                ("ModuleDeps",toNode sdps)+                ]+        writeFile fp (showYAML yaml)++collectDeps memap cs = mconcatMap f [ cu | (_,(_,cu)) <- cs] where+    f (CompSources ss) = mconcat [ (Map.singleton (sourceModName s) (sourceFP s),Map.singleton (sourceModName s) (fsts $ sourceDeps s),mempty) | s <- map sourceInfo ss ]+    f (CompLibrary _ lib) = (mempty,mempty,Map.singleton (libHash lib) (libFileName lib))+    f (CompHo _hoh idep _ho) = (Map.fromList [ (sourceModName $ sourceInfo src, sourceFP $ sourceInfo src) | s <- fsts ss, Just (Found src) <- [Map.lookup s memap] ],Map.fromList [ (mms,fsts mms') | s <- snds ss, Just (mms,mms') <- [Map.lookup s (hoIDeps idep)] ],mempty) where+        ss = [ s | s <- hoDepends idep ]+    f _ = mempty++type CompUnitGraph = [(HoHash,([HoHash],CompUnit))]++data CompUnit+    = CompHo HoHeader HoIDeps Ho+    | CompSources [SourceCode]+    | CompTCed ((HoTcInfo,TiData,[(HoHash,HsModule)],[String]))+    | CompDummy+    | CompLibrary Ho Library++instance Show CompUnit where+    showsPrec _ = shows . providesModules++data SourceInfo = SI {+    sourceHash :: SourceHash,+    sourceDeps :: [(Module,SrcLoc)],+    sourceFP :: FilePath,+    sourceModName :: Module,+    sourceHoName :: FilePath+    }++data SourceCode+    = SourceParsed     { sourceInfo :: !SourceInfo, sourceModule :: HsModule }+    | SourceRaw        { sourceInfo :: !SourceInfo, sourceLBS :: LBS.ByteString }++sourceIdent = show . sourceModName . sourceInfo++class ProvidesModules a where+    providesModules :: a -> [Module]+    providesModules _ = []++instance ProvidesModules HoIDeps where+    providesModules = fsts . hoDepends++instance ProvidesModules HoLib where+    providesModules = Map.keys . hoModuleMap++instance ProvidesModules CompUnit where+    providesModules (CompHo _ hoh _)   = providesModules hoh+    providesModules (CompSources ss) = concatMap providesModules ss+    providesModules (CompLibrary ho libr) = libProvides (hoModuleGroup ho) libr+    providesModules CompDummy = []+    providesModules (CompTCed _) = error "providesModules: bad1."++instance ProvidesModules CompLink where+    providesModules (CompLinkUnit cu) = providesModules cu+    providesModules (CompCollected _ cu) = providesModules cu+    providesModules (CompTcCollected _ cu) = providesModules cu+    providesModules (CompLinkLib _ _) = error "providesModules: bad2c."++instance ProvidesModules SourceCode where+    providesModules sp = [sourceModName (sourceInfo sp)]++-- | this walks the loaded modules and ho files, discarding out of+-- date ho files and organizing modules into their binding groups.+-- the result is an acyclic graph where the nodes are ho files, sets+-- of mutually recursive modules, or libraries.+-- there is a strict ordering of+-- source >= ho >= library+-- in terms of dependencies++toCompUnitGraph :: Done -> [Module] -> IO (HoHash,CompUnitGraph)+toCompUnitGraph done roots = do+    let fs m = map inject $ maybe (error $ "can't find deps for: " ++ show m) (fsts . snd) (Map.lookup m (knownSourceMap done))+        fs' m libr = fromMaybe (error $ "can't find deps for: " ++ show m) (Map.lookup m (hoModuleDeps $ libHoLib libr))+        foundMods = [ ((m,Left (sourceHash $ sourceInfo sc)),fs (sourceHash $ sourceInfo sc)) | (m,Found sc) <- Map.toList (modEncountered done)]+        foundMods' = Map.elems $ Map.fromList [ (mg,((mg,Right lib),fs' mg lib)) | (_,ModLibrary _ mg lib) <- Map.toList (modEncountered done)]+        fullModMap = Map.unions (map libModMap $ Map.elems (loadedLibraries done))+        inject m = Map.findWithDefault m m fullModMap+        gr = G.newGraph  (foundMods ++ foundMods') (fst . fst) snd+        gr' = G.sccGroups gr+        phomap = Map.fromListWith (++) (concat [  [ (m,[hh]) | (m,_) <- hoDepends idep ] | (hh,(_,_,idep,_)) <- Map.toList (hosEncountered done)])+        sources = Map.fromList [ (m,sourceHash $ sourceInfo sc) | (m,Found sc) <- Map.toList (modEncountered done)]++    when (dump FD.SccModules) $ do+        mapM_ (putErrLn . show) $ map (map $ fst . fst) gr'+        putErrLn $ drawForest (map (fmap (show . fst . fst)) (G.dff gr))++    cug_ref <- newIORef []+    hom_ref <- newIORef (Map.map ((,) False) $ hosEncountered done)+    ms <- forM gr' $ \ns -> do+        r <- newIORef (Left ns)+        return (Map.fromList [ (m,r) | ((m,_),_) <- ns ])+    let mods = Map.unions ms+        lmods m = fromMaybe (error $ "modsLookup: " ++ show m) (Map.lookup m mods)+    let f m = do+            rr <- readIORef (lmods m)+            case rr of+                Right hh -> return hh+                Left ns -> g ns++        g ms@(((m,Left _),_):_) = do+            let amods = map (fst . fst) ms+            pm (fromMaybe [] (Map.lookup m phomap)) $ do+                let deps = Set.toList $ Set.fromList (concat $ snds ms) `Set.difference` (Set.fromList amods)+                deps' <- snub `fmap` mapM f deps+                let mhash = MD5.md5String (concatMap (show . fst) ms ++ show deps')+                writeIORef (lmods m) (Right mhash)+                modifyIORef cug_ref ((mhash,(deps',CompSources $ map fs amods)):)+                return mhash+        g [((mg,Right lib),ds)] = do+                let Just hob = Map.lookup mg $ libBuildMap lib+                    Just hot = Map.lookup mg $ libTcMap lib+                    ho = Ho { hoModuleGroup = mg, hoBuild = hob, hoTcInfo = hot }+                    myHash = libMgHash mg lib+                deps <- snub `fmap` mapM f ds+                writeIORef (lmods mg) (Right myHash)+                modifyIORef cug_ref ((myHash,(deps,CompLibrary ho lib)):)+                return myHash+        g _ = error "Build.toCompUnitGraph: bad."+        pm :: [HoHash] -> IO HoHash -> IO HoHash+        pm [] els = els+        pm (h:hs) els = hvalid h `iocatch` (\_ -> pm hs els)+        hvalid h = do+            ll <- Map.lookup h `fmap` readIORef hom_ref+            case ll of+                Nothing -> fail "Don't know anything about this hash"+                Just (True,_) -> return h+                Just (False,af@(fp,hoh,idep,ho)) -> do+                    fp <- shortenPath fp+                    isGood <- iocatch ( mapM_ cdep (hoDepends idep) >> mapM_ hvalid (hoModDepends idep) >> return True) (\_ -> return False)+                    let isStale = not . null $ map (show . fst) (hoDepends idep) `intersect` optStale options+                        libsGood = all (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) == Just h) (hohLibDeps hoh)+                        noGood forced = do+                            putProgressLn $ printf "Stale: <%s>%s" fp forced+                            modifyIORef hom_ref (Map.delete h)+                            fail "stale file"+                    case (isStale,isGood && libsGood) of+                        (False,True) -> do+                            putProgressLn $ printf "Fresh: <%s>" fp+                            hs <- mapM f (hoModuleGroupNeeds idep)+                            modifyIORef cug_ref ((h,(hs ++ hoModDepends idep,CompHo hoh idep ho)):)+                            modifyIORef hom_ref (Map.insert h (True,af))+                            return h+                        (True,_) -> noGood " (forced)"+                        (_,False) -> noGood ""+        cdep (_,hash) | hash == MD5.emptyHash = return ()+        cdep (mod,hash) = case Map.lookup mod sources of+            Just hash' | hash == hash' -> return ()+            _ -> fail "Can't verify module up to date"+        fs m = case Map.lookup m (modEncountered done) of+            Just (Found sc) -> sc+            _ -> error $ "fs: " ++ show m+    mapM_ f (map inject roots)+    cug <- readIORef cug_ref+    let (rhash,cug') = mkPhonyCompUnit roots cug+    let gr = G.newGraph cug'  fst (fst . snd)+        gr' = G.transitiveReduction gr+    when (dump FD.SccModules) $ do+        putErrLn "ComponentsDeps:"+        mapM_ (putErrLn . show) [ (snd $ snd v, map (snd . snd) vs) | (v,vs) <- G.fromGraph gr']+    return (rhash,[ (h,([ d | (d,_) <- ns ],cu)) | ((h,(_,cu)),ns) <- G.fromGraph gr' ])++parseFiles+    :: Opt                                                  -- ^ Options to use when parsing files+    -> [FilePath]                                           -- ^ Targets we are building, used when dumping dependencies+    -> [String]                                             -- ^ Extra libraries to load+    -> [Either Module FilePath]                             -- ^ Either a module or filename to find+    -> (CollectedHo -> Ho -> IO CollectedHo)                -- ^ Process initial ho loaded from file+    -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho+    -> IO (CompNode,CollectedHo)                            -- ^ Final accumulated ho+parseFiles options targets elibs need ifunc func = do+    putProgressLn "Finding Dependencies..."+    (ksm,chash,cug) <- loadModules options targets (snub $+        if optNoAuto options then optHls options ++ elibs else+            optAutoLoads options ++ optHls options ++ elibs) bogusASrcLoc need+    cnode <- processCug cug chash+    when (optStop options == StopParse) exitSuccess+    performGC+    putProgressLn "Typechecking..."+    typeCheckGraph options cnode+    if isJust (optAnnotate options) then exitSuccess else do+    when (optStop options  == StopTypeCheck) exitSuccess+    performGC+    putProgressLn "Compiling..."+    cho <- compileCompNode ifunc func ksm cnode+    return (cnode,cho)++-- this takes a list of modules or files to load, and produces a compunit graph+loadModules+    :: Opt                      -- ^ Options to use when parsing files+    -> [FilePath]               -- ^ targets+    -> [String]                 -- ^ libraries to load+    -> SrcLoc                   -- ^ where these files are requsted from+    -> [Either Module FilePath] -- ^ a list of modules or filenames+    -> IO (Map.Map SourceHash (Module,[(Module,SrcLoc)]),HoHash,CompUnitGraph)  -- ^ the resulting acyclic graph of compilation units+loadModules modOpt targets libs sloc need = do+    theCache <- findHoCache+    case theCache of+        Just s -> putProgressLn $ printf "Using Ho Cache: '%s'" s+        Nothing -> return ()+    done_ref <- newIORef Done {+        hoCache = theCache,+        knownSourceMap = Map.empty,+        validSources = Set.empty,+        loadedLibraries = Map.empty,+        hosEncountered = Map.empty,+        modEncountered = Map.empty+        }+    (es,is) <- collectLibraries libs+    let combModMap es = Map.unions [ Map.map ((,) l) (hoModuleMap $ libHoLib l) | l <- es]+        explicitModMap = combModMap es+        implicitModMap = combModMap is+        reexported  = Set.fromList [ m | l <- es, (m,_) <- Map.toList $ hoReexports (libHoLib l) ]+        modEnc exp emap = Map.fromList [ (m,ModLibrary (exp || Set.member m reexported)  mg l) | (m,(l,mg)) <- Map.toList emap ]++    modifyIORef done_ref (loadedLibraries_u $ Map.union $ Map.fromList [ (libBaseName lib,lib) | lib <- es ++ is])+    modifyIORef done_ref (modEncountered_u $ Map.union (modEnc True explicitModMap))+    modifyIORef done_ref (modEncountered_u $ Map.union (modEnc False implicitModMap))++    forM_ (concatMap libExtraFiles (es ++ is)) $ \ef -> do+        fileInTempDir ("cbits/" ++ unpackPS (extraFileName ef)) $ \fn -> BS.writeFile fn (extraFileData ef)++    done <- readIORef done_ref+    forM_ (Map.elems $ loadedLibraries done) $ \ lib -> do+        let libsBad = filter (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) /= Just h) (hohLibDeps $ libHoHeader lib)+        unless (null libsBad) $ do+            putErr $ printf "Library Dependencies not met. %s needs\n" (libName lib)+            forM_ libsBad $ \ (p,h) -> putErr $ printf "    %s (hash:%s)\n" (unpackPS p) (show h)+            putErrDie "\n"+    ms1 <- forM (rights need) $ \fn -> do+        fetchSource modOpt done_ref [fn] Nothing+    forM_ (map (,sloc) $ lefts need) $ resolveDeps modOpt done_ref+    processIOErrors+    done <- readIORef done_ref+    let needed = (ms1 ++ lefts need)+    (chash,cug) <- toCompUnitGraph done needed+    dumpDeps targets (modEncountered done) cug+    return (Map.filterWithKey (\k _ -> k `Set.member` validSources done) (knownSourceMap done),chash,cug)++-- turn the list of CompUnits into a true mutable graph.+processCug :: CompUnitGraph -> HoHash -> IO CompNode+processCug cug root = mdo+    let mmap = Map.fromList xs+        lup x = maybe (error $ "processCug: " ++ show x) id (Map.lookup x mmap)+        f (h,(ds,cu)) = do+            cur <- newIORef (CompLinkUnit cu)+            return $ (h,CompNode h (map lup ds) cur)+    xs <- mapM f cug+    Just x <- return $ Map.lookup root mmap+    return $ x++mkPhonyCompUnit :: [Module] -> CompUnitGraph -> (HoHash,CompUnitGraph)+mkPhonyCompUnit need cs = (fhash,(fhash,(fdeps,CompDummy)):cs) where+        fhash = MD5.md5String $ show (sort fdeps)+        fdeps = [ h | (h,(_,cu)) <- cs, not . null $ providesModules cu `intersect` need ]++printModProgress :: Int -> Int -> IO Int -> [HsModule] -> IO ()+printModProgress _ _ _ [] = return ()+printModProgress _ _ tickProgress ms | not progress = mapM_ (const tickProgress) ms+printModProgress fmtLen maxModules tickProgress ms = f "[" ms where+    f bl ms = do+        curModule <- tickProgress+        case ms of+            [x] -> g curModule bl "]" x+            (x:xs) -> do g curModule bl "-" x; putErrLn ""; f "-" xs+            _ -> error "Build.printModProgress: bad."+    g curModule bl el modName = putErr $ printf "%s%*d of %*d%s %-17s" bl fmtLen curModule fmtLen maxModules el (show $ hsModuleName modName)++countNodes cn = do+    seen <- newIORef Set.empty+    let h (CompNode hh deps ref) = do+            s <- readIORef seen+            if hh `Set.member` s then return Set.empty else do+                writeIORef seen (Set.insert hh s)+                ds <- mapM h deps+                cm <- readIORef ref >>= g+                return (Set.unions (cm:ds))+        g cn = case cn of+            CompLinkUnit cu      -> return $ f cu+            CompTcCollected _ cu -> return $ f cu+            CompCollected _ cu   -> return $ f cu+            CompLinkLib _ _      -> error "Build.countNodes: bad."+        f cu = case cu of+            CompTCed (_,_,_,ss) -> Set.fromList ss+            CompSources sc      -> Set.fromList (map sourceIdent sc)+            _                   -> Set.empty+    h cn++typeCheckGraph :: Opt -> CompNode -> IO ()+typeCheckGraph modOpt cn = do+    cur <- newMVar (1::Int)+    maxModules <- Set.size `fmap` countNodes cn+    let f (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of+            CompTcCollected ctc _ -> return ctc+            CompLinkUnit lu -> do+                deps' <- randomPermuteIO deps+                ctc <- mconcat `fmap` mapM f deps'+                case lu of+                    CompDummy -> do+                        writeIORef ref (CompTcCollected ctc CompDummy)+                        return ctc+                    CompHo hoh idep ho  -> do+                        let ctc' = hoTcInfo ho `mappend` ctc+                        writeIORef ref (CompTcCollected ctc' lu)+                        return ctc'+                    CompLibrary ho _libr  -> do+                        let ctc' = hoTcInfo ho `mappend` ctc+                        writeIORef ref (CompTcCollected ctc' lu)+                        return ctc'+                    CompSources sc -> do+                        let mods = sort $ map (sourceModName . sourceInfo) sc+                        modules <- forM sc $ \x -> case x of+                            SourceParsed { sourceInfo = si, sourceModule = sm } ->+                                return (sourceHash si, sm, error "SourceParsed in AnnotateSource")+                            SourceRaw { sourceInfo = si, sourceLBS = lbs } -> do+                                (mod,lbs') <- parseHsSource modOpt (sourceFP si) lbs+                                case optAnnotate modOpt of+                                    Just fp -> do+                                        let ann = LBSU.fromString $ unlines [+                                                "{- --ANNOTATE--",+                                                "Module: " ++ show (sourceModName si),+                                                "Deps: " ++ show (sort $ fsts $ sourceDeps si),+                                                "Siblings: " ++ show mods,+                                                "-}"]+                                        LBS.writeFile (fp ++ "/" ++ show (hsModuleName mod) ++ ".hs") (ann `LBS.append` lbs')+                                    _ -> return ()+                                return (sourceHash si,mod,lbs')+                        showProgress (map snd3 modules)+                        (htc,tidata) <- doModules ctc (map snd3 modules)+                        let ctc' = htc `mappend` ctc+                        writeIORef ref (CompTcCollected ctc' (CompTCed ((htc,tidata,[ (x,y) | (x,y,_) <- modules],map (sourceHoName . sourceInfo) sc))))+                        return ctc'+                    _ -> error "Build.typeCheckGraph: bad1."+            _ -> error "Build.typeCheckGraph: bad2."+        showProgress ms = printModProgress fmtLen maxModules tickProgress ms+        fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int+        tickProgress = modifyMVar cur $ \val -> return (val+1,val)+    f cn+    return ()++compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo)                 -- ^ Process initial ho loaded from file+                -> (CollectedHo -> Ho -> TiData  -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho+                -> Map.Map SourceHash (Module,[(Module,SrcLoc)])+                -> CompNode+                -> IO CollectedHo+compileCompNode ifunc func ksm cn = do+    cur <- newMVar (1::Int)+    ksm_r <- newIORef ksm+    let tickProgress = modifyMVar cur $ \val -> return (val+1,val)+    maxModules <- Set.size `fmap` countNodes cn+    let showProgress ms = printModProgress fmtLen maxModules tickProgress ms+        fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int+    let f (CompNode hh deps ref) = readIORef ref >>= g where+            g cn = case cn of+                CompCollected ch _ -> return ch+                CompTcCollected _ cl -> h cl+                CompLinkUnit cu -> h cu+                _ -> error "Build.compileCompNode: bad."+            h cu = do+                deps' <- randomPermuteIO deps+                cho <- mconcat `fmap` mapM f deps'++                case cu of+                    CompDummy -> do+                        writeIORef ref (CompCollected cho CompDummy)+                        return cho+                    (CompHo hoh idep ho) -> do+                        cho <- choLibDeps_u (Map.union $ Map.fromList (hohLibDeps hoh)) `fmap` ifunc cho ho+                        writeIORef ref (CompCollected cho cu)+                        return cho+                    (CompLibrary ho Library { libHoHeader = hoh }) -> do+                        cho <- ifunc cho ho+                        let Right (ln,_) = hohName hoh+                            lh = hohHash hoh+                            cho' = (choLibDeps_u (Map.insert ln lh) cho)+                        writeIORef ref (CompCollected cho' cu)+                        return cho'+                    CompTCed ((htc,tidata,modules,shns))  -> do+                        (hdep,ldep) <- fmap mconcat . forM deps $ \ (CompNode h _ ref) -> do+                            cl <- readIORef ref+                            case compLinkCompUnit cl of+                                CompLibrary ho _ -> return ([],[hoModuleGroup ho])+                                CompDummy {} -> return ([],[])+                                _ -> return ([h],[])+                        showProgress (snds modules)+                        let (mgName:_) = sort $ map (hsModuleName . snd) modules+                        (cho',newHo) <- func cho mempty { hoModuleGroup = mgName, hoTcInfo = htc } tidata+                        modifyIORef ksm_r (Map.union $ Map.fromList [ (h,(hsModuleName mod, hsModuleRequires mod)) | (h,mod) <- modules])+                        ksm <- readIORef ksm_r+                        let hoh = HoHeader {+                                     hohVersion = error "hohVersion",+                                     hohName = Left mgName,+                                     hohHash       = hh,+                                     hohArchDeps = [],+                                     hohLibDeps   = Map.toList (choLibDeps cho')+                                     }+                            idep = HoIDeps {+                                    hoIDeps      = ksm,+                                    hoDepends    = [ (hsModuleName mod,h) | (h,mod) <- modules],+                                    hoModDepends = hdep,+                                    hoModuleGroupNeeds = ldep+                                    }+                        recordHoFile (mapHoBodies eraseE newHo) idep shns hoh+                        writeIORef ref (CompCollected cho' (CompHo hoh idep newHo))+                        return cho'+                    CompSources _ -> error "sources still exist!?"+    f cn++hsModuleRequires x = snub ((toModule "Jhc.Prim.Prim",bogusASrcLoc):ans) where+    noPrelude = FO.Prelude `Set.notMember` optFOptsSet (hsModuleOpt x)+    ans = (if noPrelude then id else ((preludeModule,bogusASrcLoc):)) [  (hsImportDeclModule y,hsImportDeclSrcLoc y) | y <- hsModuleImports x]++searchPaths :: Opt -> String -> [(String,String)]+searchPaths modOpt m = ans where+    f m | (xs,'.':ys) <- span (/= '.') m = let n = (xs ++ "/" ++ ys) in m:f n+        | otherwise = [m]+    ans = [ (root ++ suf,root ++ ".ho") | i <- optIncdirs modOpt, n <- f m, suf <- [".hs",".lhs",".hsc"], let root = i ++ "/" ++ n]++mapHoBodies  :: (E -> E) -> Ho -> Ho+mapHoBodies sm ho = ho { hoBuild = g (hoBuild ho) } where+    g ho = ho { hoEs = map f (hoEs ho) , hoRules =  runIdentity (E.Rules.mapBodies (return . sm) (hoRules ho)) }+    f (t,e) = (t,sm e)++eraseE :: E -> E+eraseE e = runIdentity $ f e where+    f (EVar tv) = return $ EVar  tvr { tvrIdent = tvrIdent tv }+    f e = emapE f e++---------------------------------+-- library specific routines+---------------------------------++buildLibrary :: (CollectedHo -> Ho -> IO CollectedHo)+             -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho+             -> FilePath+             -> IO ()+buildLibrary ifunc func = ans where+    ans fp = do+        (desc,name,vers,hmods,emods,modOpts,sources) <- parse fp+        vers <- runReadP parseVersion vers+        let allMods = emodSet `Set.union` hmodSet+            emodSet = Set.fromList emods+            hmodSet = Set.fromList hmods+        let outName = case optOutName modOpts of+                Nothing -> name ++ "-" ++ showVersion vers ++ ".hl"+                Just fn -> fn+        -- TODO - must check we depend only on libraries+        (rnode@(CompNode lhash _ _),cho) <- parseFiles modOpts [outName] [] (map Left $ Set.toList allMods) ifunc func+        (_,(mmap,mdeps,prvds,lcor,ldef)) <- let+            f (CompNode hs cd ref) = do+                cl <- readIORef ref+                case cl of+                    CompLinkLib l _ -> return l+                    CompCollected _ y -> g hs cd ref y+                    _ -> error "Build.buildLibrary: bad1."+            g hh deps ref cn = do+                deps <- mapM f deps+                let (mg,mll) = case cn of+                        CompDummy -> (error "modgroup of dummy",mempty)+                        CompLibrary ho lib -> (hoModuleGroup ho,mempty)+                        CompHo hoh hidep ho -> (mg,(+                                    Map.fromList $ zip (providesModules hidep) (repeat mg),+                                    Map.singleton mg (sort $ fsts deps),+                                    Set.fromList $ providesModules hidep,+                                    Map.singleton mg (hoBuild ho'),+                                    Map.singleton mg (hoTcInfo ho')+                                    )) where+                                        mg = hoModuleGroup ho+                                        ho' = mapHoBodies eraseE ho+                        _ -> error "Build.buildLibrary: bad2."+                    res = (mg,mconcat (snds deps) `mappend` mll)+                writeIORef ref (CompLinkLib res cn)+                return res+          in f rnode+        let unknownMods = Set.toList $ Set.filter (`Set.notMember` allMods) prvds+        mapM_ ((putStrLn . ("*** Module depended on in library that is not in export list: " ++)) . show) unknownMods+        mapM_ ((putStrLn . ("*** We are re-exporting the following modules from other libraries: " ++)) . show) $ Set.toList (allMods Set.\\ prvds)+        let hoh =  HoHeader {+                hohHash = lhash,+                hohName = Right (packString name,vers),+                hohLibDeps = Map.toList (choLibDeps cho),+                hohArchDeps = [],+                hohVersion = error "hohVersion"+                }+        let pdesc = [(packString n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ]+            libr = HoLib {+                hoReexports = Map.fromList [ (m,m) | m <- Set.toList $ allMods Set.\\ prvds ],+                hoMetaInfo = pdesc,+                hoModuleMap = mmap,+                hoModuleDeps = mdeps+                }+        putProgressLn $ "Writing Library: " ++ outName+        efs <- mapM fetchExtraFile sources+        recordHlFile Library { libHoHeader = hoh, libHoLib =  libr, libTcMap = ldef,+            libBuildMap = lcor, libFileName = outName, libExtraFiles = efs }+    -- parse library description file+    parse fp = do+        putProgressLn $ "Creating library from description file: " ++ show fp+        LibDesc dlist dsing <- readDescFile fp+        when verbose2 $ do+            mapM_ print (Map.toList dlist)+            mapM_ print (Map.toList dsing)+        let jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ Map.lookup x dsing+            mfield x = maybe [] id $ Map.lookup x dlist+            --mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ Map.lookup x dlist+        name <- jfield "name"+        vers <- jfield "version"+        let (modOpts,flags) = (lproc bopt,modOptions) where+                Just bopt = fileOptions options modOptions `mplus` Just options+                (pfs,nfs,_) = languageFlags (mfield "extensions")+                lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs }+                dirs = [ "-i" ++ dd x | x <- mfield "hs-source-dirs" ]+                    ++ [ "-I" ++ dd x | x <- mfield "include-dirs" ]+                    ++ [ "-p" ++ x | x <- mfield "build-depends" ]+                modOptions =  (mfield "options" ++ dirs)+                dd "." = FP.takeDirectory fp+                dd ('.':'/':x) = dd x+                dd x = FP.takeDirectory fp FP.</> x+        when verbose $+            print (flags,optFOptsSet modOpts)+        let hmods = map toModule $ snub $ mfield "hidden-modules"+            emods = map toModule $ snub $ mfield "exposed-modules"+            sources = map (FP.takeDirectory fp FP.</>) $ snub $ mfield "c-sources" ++ mfield "include-sources"+        return (Map.toList dsing,name,vers,hmods,emods,modOpts,sources)++fetchExtraFile fp = do+    c <- BS.readFile fp+    return ExtraFile { extraFileName = packString (FP.takeFileName fp),+                       extraFileData = c }++------------------------------------+-- dumping contents of a ho file+------------------------------------++instance DocLike d => PPrint d MD5.Hash where+    pprint h = tshow h++instance DocLike d => PPrint d SrcLoc where+    pprint sl = tshow sl++instance DocLike d => PPrint d Version where+    pprint sl = text $ showVersion sl++instance DocLike d => PPrint d PackedString where+    pprint sl = text (unpackPS sl)++{-# NOINLINE dumpHoFile #-}+dumpHoFile :: String -> IO ()+dumpHoFile fn = ans where+    ans = do+        putStrLn fn+        case reverse fn of+            'l':'h':'.':_ -> doHl fn+            'o':'h':'.':_ -> doHo fn+            _ -> putErrDie "Error: --show-ho requires a .hl or .ho file"+    vindent xs = vcat (map ("    " ++) xs)+    showList nm xs = when (not $ null xs) $ putStrLn $ (nm ++ ":\n") <>  vindent xs+    doHoh hoh = do+        putStrLn $ "Version:" <+> pprint (hohVersion hoh)+        putStrLn $ "Hash:" <+> pprint (hohHash hoh)+        putStrLn $ "Name:" <+> pprint (hohName hoh)+        showList "LibDeps" (map pprint . sortUnder fst $ hohLibDeps hoh)+        showList "ArchDeps" (map pprint . sortUnder fst $ hohArchDeps hoh)+    doHl fn = do+        l <- readHlFile fn+        doHoh $ libHoHeader l+        showList "MetaInfo" (sort [text (unpackPS k) <> char ':' <+> show v |+                                   (k,v) <- hoMetaInfo (libHoLib l)])+        showList "ModuleMap" (map pprint . sortUnder fst $ Map.toList $ hoModuleMap $ libHoLib l)+        showList "ModuleDeps" (map pprint . sortUnder fst $ Map.toList $ hoModuleDeps $ libHoLib l)+        showList "ModuleReexports" (map pprint . sortUnder fst $ Map.toList $ hoReexports $ libHoLib l)+        forM_ (Map.toList $ libBuildMap l) $ \ (g,hoB) -> do+            print g+            doHoB hoB+    doHo fn = do+        (hoh,idep,ho) <- readHoFile fn+        doHoh hoh+        let hoB = hoBuild ho+            hoE = hoTcInfo ho+        showList "Dependencies" (map pprint . sortUnder fst $ hoDepends idep)+        showList "ModDependencies" (map pprint $ hoModDepends idep)+        showList "IDepCache" (map pprint . sortUnder fst $ Map.toList $ hoIDeps idep)+        putStrLn $ "Modules contained:" <+> tshow (keys $ hoExports hoE)+        putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE)+        putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoE)+        putStrLn $ "hoFixities:" <+> tshow (size $  hoFixities hoE)+        putStrLn $ "hoKinds:" <+> tshow (size $  hoKinds hoE)+        putStrLn $ "hoClassHierarchy:" <+> tshow (length $ classRecords $ hoClassHierarchy hoE)+        putStrLn $ "hoTypeSynonyms:" <+> tshow (size $  hoTypeSynonyms hoE)+        wdump FD.Exports $ do+            putStrLn "---- exports information ----";+            putStrLn $  (pprint $ hoExports hoE :: String)+        wdump FD.Defs $ do+            putStrLn "---- defs information ----";+            putStrLn $  (pprint $ hoDefs hoE :: String)+        when (dump FD.Kind) $ do+            putStrLn "---- kind information ----";+            putStrLn $  (pprint $ hoKinds hoE :: String)+        when (dump FD.ClassSummary) $ do+            putStrLn "---- class summary ---- "+            printClassSummary (hoClassHierarchy hoE)+        when (dump FD.Class) $+             do {putStrLn "---- class hierarchy ---- ";+                 printClassHierarchy (hoClassHierarchy hoE)}+        wdump FD.Types $ do+            putStrLn " ---- the types of identifiers ---- "+            putStrLn $ PPrint.render $ pprint (hoAssumps hoE)+        doHoB hoB+    doHoB hoB = do+        putStrLn $ "hoDataTable:" <+> tshow (size $  hoDataTable hoB)+        putStrLn $ "hoEs:" <+> tshow (size $  hoEs hoB)+        putStrLn $ "hoRules:" <+> tshow (size $  hoRules hoB)+        let rules = hoRules hoB+        wdump FD.Rules $ putStrLn "  ---- user rules ---- " >> printRules RuleUser rules+        wdump FD.Rules $ putStrLn "  ---- user catalysts ---- " >> printRules RuleCatalyst rules+        wdump FD.RulesSpec $ putStrLn "  ---- specializations ---- " >> printRules RuleSpecialization rules+        wdump FD.Datatable $ do+             putStrLn "  ---- data table ---- "+             putDocM putStr (showDataTable (hoDataTable hoB))+             putChar '\n'+        wdump FD.Core $ do+            putStrLn " ---- lambdacube  ---- "+            mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB)+    printCheckName'' :: DataTable -> TVr -> E -> IO ()+    printCheckName'' _dataTable tvr e = do+        when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr)+        putStrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr)))+        putStrLn (render $ hang 4 (pprint tvr <+> equals <+> pprint e))+{-* Generated by DrIFT : Look, but Don't Touch. *-}+--  Imported from other files :-
+ drift_processed/Ho/Type.hs view
@@ -0,0 +1,245 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/Ho/Type.hs" #-}+module Ho.Type where++import Data.Monoid+import qualified Data.ByteString as BS+import qualified Data.Map as Map++import Data.Version+import DataConstructors(DataTable)+import E.Rules(Rules)+import E.Type+import E.TypeCheck()+import FrontEnd.Class(ClassHierarchy)+import FrontEnd.Infix(FixityMap)+import FrontEnd.KindInfer(KindEnv)+import FrontEnd.Rename(FieldMap())+import FrontEnd.SrcLoc(SrcLoc)+import FrontEnd.Tc.Type(Type())+import FrontEnd.TypeSynonyms(TypeSynonyms)+import Name.Id+import Name.Name(Name,Module)+import PackedString+import Support.CFF+import Support.MapBinaryInstance()+import qualified Support.MD5 as MD5++cff_magic = chunkType "JHC"+cff_link  = chunkType "LINK"+cff_libr  = chunkType "LIBR"+cff_jhdr  = chunkType "JHDR"+cff_core  = chunkType "CORE"+cff_defs  = chunkType "DEFS"+cff_lcor  = chunkType "LCOR"+cff_ldef  = chunkType "LDEF"+cff_idep  = chunkType "IDEP"+cff_file  = chunkType "FILE"++-- A SourceHash is the hash of a specific file, it is associated with a+-- specific 'Module' that said file implements.+type SourceHash = MD5.Hash+-- HoHash is a unique identifier for a ho file or library.+type HoHash     = MD5.Hash++-- while a 'Module' is a single Module associated with a single haskell source+-- file, a 'ModuleGroup' identifies a group of mutually recursive modules.+-- Generally it is chosen from among the Modules making up the group, but the+-- specific choice has no other meaning. We could use the HoHash, but for readability+-- reasons when debugging it makes more sense to choose an arbitrary Module.+type ModuleGroup = Module++-- the collected information that is passed around+-- this is not stored in any file, but is what is collected from the ho files.+data CollectedHo = CollectedHo {+    -- this is a list of external names that are valid but that we may not know+    -- anything else about it is used to recognize invalid ids.+    choExternalNames :: IdSet,+    -- these are the functions in Comb form.+    choCombinators  :: IdMap Comb,+    -- these are rules that may need to be retroactively applied to other+    -- modules+    choOrphanRules :: Rules,+    -- the hos+    choHoMap :: Map.Map ModuleGroup Ho,+    -- libraries depended on+    choLibDeps :: Map.Map PackedString HoHash,+    -- these are caches of pre-computed values+    choHo :: Ho, -- ^ cache of combined and renamed ho+    choVarMap :: IdMap (Maybe E) -- ^ cache of variable substitution map+    }+    {-! derive: update !-}++-- The header contains basic information about the file, it should be enough to determine whether+-- we can discard the file right away or consider it further.++data HoHeader = HoHeader {+    -- * the version of the file format. it comes first so we don't try to read data that may be in a different format.+    hohVersion  :: Int,+    -- * my sha1 id+    hohHash     :: HoHash,+    -- * the human readable name, either the ModuleGroup or the library name and version.+    hohName     :: Either ModuleGroup (PackedString,Version),+    -- * library dependencies+    hohLibDeps  :: [(PackedString,HoHash)],+    -- * arch dependencies, these say whether the file is specialized for a+    -- given arch.+    hohArchDeps :: [(PackedString,PackedString)]+    }++-- These are the dependencies needed to check if a ho file is up to date.  it+-- only appears in ho files as hl files do not have source code to check+-- against or depend on anything but other libraries.+data HoIDeps = HoIDeps {+    -- * modules depended on indexed by a hash of the source.+    hoIDeps :: Map.Map SourceHash (Module,[(Module,SrcLoc)]),+    -- * Haskell Source files depended on+    hoDepends    :: [(Module,SourceHash)],+    -- * Other objects depended on to be considered up to date.+    hoModDepends :: [HoHash],+    -- * library module groups needed+    hoModuleGroupNeeds :: [ModuleGroup]+    }++data HoLib = HoLib {+    -- * arbitrary metainformation such as library author, web site, etc.+    hoModuleMap  :: Map.Map Module ModuleGroup,+    hoReexports  :: Map.Map Module Module,+    hoModuleDeps :: Map.Map ModuleGroup [ModuleGroup],+    hoMetaInfo   :: [(PackedString,PackedString)]+    }++data Library = Library {+    libHoHeader :: HoHeader,+    libHoLib :: HoLib,+    libTcMap :: (Map.Map ModuleGroup HoTcInfo),+    libBuildMap :: (Map.Map ModuleGroup HoBuild),+    libExtraFiles :: [ExtraFile],+    libFileName :: FilePath+    }++instance Show Library where+    showsPrec n lib = showsPrec n (hohHash $ libHoHeader lib)++-- data only needed for type checking.+data HoTcInfo = HoTcInfo {+    hoExports :: Map.Map Module [Name],+    hoDefs :: Map.Map Name (SrcLoc,[Name]),+    hoAssumps :: Map.Map Name Type,        -- used for typechecking+    hoFixities :: FixityMap,+    hoKinds :: KindEnv,                    -- used for typechecking+    hoTypeSynonyms :: TypeSynonyms,+    hoClassHierarchy :: ClassHierarchy,+    hoFieldMap :: FieldMap+    }+    {-! derive: update, Monoid !-}++data HoBuild = HoBuild {+    -- Filled in by E generation+    hoDataTable :: DataTable,+    hoEs :: [(TVr,E)],+    hoRules :: Rules+    }+    {-! derive: update, Monoid !-}++data Ho = Ho {+    hoModuleGroup :: ModuleGroup,+    hoTcInfo :: HoTcInfo,+    hoBuild :: HoBuild+    }+    {-! derive: update !-}++instance Monoid Ho where+    mempty = Ho (error "unknown module group") mempty mempty+    mappend ha hb = Ho (hoModuleGroup ha) (hoTcInfo ha `mappend` hoTcInfo hb) (hoBuild ha `mappend` hoBuild hb)++data ExtraFile = ExtraFile {+    extraFileName :: PackedString,+    extraFileData :: BS.ByteString+    }++{-+instance Monoid Ho where+    mempty = Ho mempty mempty+    mappend a b = Ho {+        hoTcInfo = hoTcInfo a `mappend` hoTcInfo b,+        hoBuild = hoBuild a `mappend` hoBuild b+    }++instance Monoid HoTcInfo where+    mempty = HoTcInfo mempty mempty+    mappend a b = HoTcInfo {+        hoExports = hoExports a `mappend` hoExports b,+        hoDefs = hoDefs a `mappend` hoDefs b+    }++instance Monoid HoBuild where+    mempty = HoBuild mempty mempty mempty mempty mempty mempty mempty mempty+    mappend a b = HoBuild {+        hoAssumps = hoAssumps a `mappend` hoAssumps b,+        hoFixities = hoFixities a `mappend` hoFixities b,+        hoKinds = hoKinds a `mappend` hoKinds b,+        hoClassHierarchy = hoClassHierarchy a `mappend` hoClassHierarchy b,+        hoTypeSynonyms = hoTypeSynonyms a `mappend` hoTypeSynonyms b,+        hoDataTable = hoDataTable a `mappend` hoDataTable b,+        hoEs = hoEs a `mappend` hoEs b,+        hoRules = hoRules a `mappend` hoRules b+    }++ -}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+choCombinators_u f r@CollectedHo{choCombinators  = x} = r{choCombinators = f x}+choExternalNames_u f r@CollectedHo{choExternalNames  = x} = r{choExternalNames = f x}+choHo_u f r@CollectedHo{choHo  = x} = r{choHo = f x}+choHoMap_u f r@CollectedHo{choHoMap  = x} = r{choHoMap = f x}+choLibDeps_u f r@CollectedHo{choLibDeps  = x} = r{choLibDeps = f x}+choOrphanRules_u f r@CollectedHo{choOrphanRules  = x} = r{choOrphanRules = f x}+choVarMap_u f r@CollectedHo{choVarMap  = x} = r{choVarMap = f x}+choCombinators_s v =  choCombinators_u  (const v)+choExternalNames_s v =  choExternalNames_u  (const v)+choHo_s v =  choHo_u  (const v)+choHoMap_s v =  choHoMap_u  (const v)+choLibDeps_s v =  choLibDeps_u  (const v)+choOrphanRules_s v =  choOrphanRules_u  (const v)+choVarMap_s v =  choVarMap_u  (const v)++hoAssumps_u f r@HoTcInfo{hoAssumps  = x} = r{hoAssumps = f x}+hoClassHierarchy_u f r@HoTcInfo{hoClassHierarchy  = x} = r{hoClassHierarchy = f x}+hoDefs_u f r@HoTcInfo{hoDefs  = x} = r{hoDefs = f x}+hoExports_u f r@HoTcInfo{hoExports  = x} = r{hoExports = f x}+hoFieldMap_u f r@HoTcInfo{hoFieldMap  = x} = r{hoFieldMap = f x}+hoFixities_u f r@HoTcInfo{hoFixities  = x} = r{hoFixities = f x}+hoKinds_u f r@HoTcInfo{hoKinds  = x} = r{hoKinds = f x}+hoTypeSynonyms_u f r@HoTcInfo{hoTypeSynonyms  = x} = r{hoTypeSynonyms = f x}+hoAssumps_s v =  hoAssumps_u  (const v)+hoClassHierarchy_s v =  hoClassHierarchy_u  (const v)+hoDefs_s v =  hoDefs_u  (const v)+hoExports_s v =  hoExports_u  (const v)+hoFieldMap_s v =  hoFieldMap_u  (const v)+hoFixities_s v =  hoFixities_u  (const v)+hoKinds_s v =  hoKinds_u  (const v)+hoTypeSynonyms_s v =  hoTypeSynonyms_u  (const v)++instance Monoid HoTcInfo where+    mempty = HoTcInfo mempty mempty mempty mempty mempty mempty mempty mempty+    mappend (HoTcInfo aa ab ac ad ae af ag ah) (HoTcInfo aa' ab' ac' ad' ae' af' ag' ah') = HoTcInfo (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')(mappend af af')(mappend ag ag')(mappend ah ah')++hoDataTable_u f r@HoBuild{hoDataTable  = x} = r{hoDataTable = f x}+hoEs_u f r@HoBuild{hoEs  = x} = r{hoEs = f x}+hoRules_u f r@HoBuild{hoRules  = x} = r{hoRules = f x}+hoDataTable_s v =  hoDataTable_u  (const v)+hoEs_s v =  hoEs_u  (const v)+hoRules_s v =  hoRules_u  (const v)++instance Monoid HoBuild where+    mempty = HoBuild mempty mempty mempty+    mappend (HoBuild aa ab ac) (HoBuild aa' ab' ac') = HoBuild (mappend aa aa')(mappend ab ab')(mappend ac ac')++hoBuild_u f r@Ho{hoBuild  = x} = r{hoBuild = f x}+hoModuleGroup_u f r@Ho{hoModuleGroup  = x} = r{hoModuleGroup = f x}+hoTcInfo_u f r@Ho{hoTcInfo  = x} = r{hoTcInfo = f x}+hoBuild_s v =  hoBuild_u  (const v)+hoModuleGroup_s v =  hoModuleGroup_u  (const v)+hoTcInfo_s v =  hoTcInfo_u  (const v)++--  Imported from other files :-
+ drift_processed/Name/VConsts.hs view
@@ -0,0 +1,94 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/Name/VConsts.hs" #-}+module Name.VConsts where++import Control.Applicative+import Data.Foldable+import Data.Monoid+import Data.Traversable++-- This is much more verbose/complicated than it needs be.++class TypeNames a where+    tInt :: a+    tRational :: a+    tChar :: a+    tIntzh :: a+    tEnumzh :: a+    tCharzh :: a+    tBool :: a+    tUnit :: a+    tString :: a+    tInteger :: a+    tWorld__ :: a++    tInt = error "tInt"+    tRational = error "tRational"+    tChar = error "tChar"+    tIntzh = error "tIntzh"+    tEnumzh = error "tEnumzh"+    tCharzh = error "tCharzh"+    tBool = error "tBool"+    tUnit = error "tUnit"+    tString = error "tString"+    tInteger = error "tInteger"+    tWorld__ = error "tWorld"++class ConNames a where+    vTrue :: a+    vFalse :: a+    vCons :: a+    vUnit :: a++    vTrue = error "vTrue"+    vFalse = error "vFalse"+    vCons = error "vCons"+    vUnit = error "vUnit"++class FromTupname a where+    fromTupname :: Monad m => a -> m Int++instance FromTupname String where+    fromTupname ('(':s) | (cs,")") <- span (== ',') s, lc <- length cs, lc > 0 = return $! (lc + 1)+    fromTupname xs = fail $ "fromTupname: not tuple " ++ xs++instance FromTupname (String,String) where+    fromTupname ("Jhc.Prim.Prim",n) = fromTupname n+    fromTupname xs =  fail $ "fromTupname: not tuple " ++ show xs++class ToTuple a where+    toTuple :: Int -> a++instance ToTuple String where+    toTuple n = '(': replicate (n - 1) ',' ++ ")"++instance ToTuple (String,String) where+    toTuple n = ("Jhc.Prim.Prim",toTuple n)++-- | various functions needed for desugaring.+data FuncNames a = FuncNames {+    func_equals :: a,+    func_fromInt :: a,+    func_fromInteger :: a,+    func_fromRational :: a,+    func_negate :: a,+    func_runExpr :: a,+    func_runMain :: a,+    func_runNoWrapper :: a,+    func_runRaw :: a+    }+    {-! derive: Functor, Traversable, Foldable !-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Functor FuncNames where+    fmap f (FuncNames aa ab ac ad ae af ag ah+	    ai) = FuncNames (f aa) (f ab) (f ac) (f ad) (f ae) (f af) (f ag) (f ah) (f ai)++instance Data.Traversable.Traversable FuncNames where+    traverse f (FuncNames aa ab ac ad ae af ag ah+		ai) = FuncNames <$> f aa <*> f ab <*> f ac <*> f ad <*> f ae <*> f af <*> f ag <*> f ah <*> f ai++instance Foldable FuncNames where+    foldMap f (FuncNames aa ab ac ad ae af ag ah+	       ai) = (f aa) `Data.Monoid.mappend` (f ab) `Data.Monoid.mappend` (f ac) `Data.Monoid.mappend` (f ad) `Data.Monoid.mappend` (f ae) `Data.Monoid.mappend` (f af) `Data.Monoid.mappend` (f ag) `Data.Monoid.mappend` (f ah) `Data.Monoid.mappend` (f ai)++--  Imported from other files :-
+ drift_processed/Options.hs view
@@ -0,0 +1,597 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "src/Options.hs" #-}+{-# OPTIONS -w -funbox-strict-fields #-}+module Options(+    processOptions,+    Opt(..),+    options,+    Mode(..),+    StopCondition(..),+    putVerbose,+    putVerboseLn,+    putProgress,+    putProgressLn,+    getArguments,+    findHoCache,+    verbose,+    verbose2,+    progress,+    dump,+    wdump,+    fopts,+    flint,+    fileOptions,+    withOptions,+    withOptionsT,+    getArgString,+    outputName,+    OptM(),+    OptT(),+    OptionMonad(..),+    flagOpt+    ) where++import Control.Monad.Error()    -- IO MonadPlus instance+import Control.Monad.Identity+import Control.Monad.Reader+import Data.List(nub)+import Data.Maybe+import System.Console.GetOpt+import System.Directory+import System.IO.Unsafe+import System.Environment+import System.Exit+import qualified Data.ByteString.UTF8 as BS+import qualified Data.Map as M+import qualified Data.Set as S++import RawFiles(targets_ini)+import Support.IniParse+import Support.TempDir+import Support.Cabal+import Util.ExitCodes+import Util.Gen+import Util.YAML+import Version.Config+import Version.Version(versionString,versionContext)+import qualified FlagDump+import qualified FlagOpts+import qualified Version.Config as VC++{-@CrossCompilation++# Basics++Unlike many other compilers, Ajhc is a native cross compiler. What this means is+that every compile of Ajhc is able to create code for all possible target+systems. This leads to many simplifications when it comes to cross compiling+with Ajhc. Basically in order to cross compile, you need only pass the flag+'--cross' to Ajhc, and pass an appropriate '-m' option to tell Ajhc what machine+you are targetting. An example would be++    ; ajhc --cross -mwin32 test/HelloWorld.hs++The targets list is extensible at run-time via the targets.ini file explained+below.++# targets.ini++This file determines what targets are available. The format consists of entries as follows.++    [targetname]+    key1=value+    key2=value+    key3+=value+    merge=targetname2++merge is a special key meaning to merge the contents of another target into the+current one. The configuration file is read in order, and the final value set+for a given key is the one that is used.++An example describing how to cross compile for windows is as follows:++    [win32]+    cc=i386-mingw32-gcc+    cflags+=-mwindows -mno-cygwin+    executable_extension=.exe+    merge=i686++This sets the compiler to use as well as a few other options then jumps to the+generic i686 routine. The special target [default] is always read before all+other targets. If '--cross' is specified on the command line then this is the+only implicitly included configuration, otherwise Ajhc will assume you are+compiling for the current architecture and choose an appropriate target to+include in addition to default.++Ajhc will attempt to read several targets.ini files in order. they are++$PREFIX/etc/ajhc-\$VERSION/targets.ini+: this is the targets.ini that is included with Ajhc and contains the default options.++$PREFIX/etc/ajhc-\$VERSION/targets-local.ini+: Ajhc will read this if it exists, it is used to specify custom system wide configuration options, such as the name of local compilers.++$HOME/.ajhc/targets.ini+: this is where a users local configuration information goes.++$HOME/etc/ajhc/targets.ini+: this is simply for people that prefer to not use hidden directories for configuration++The last value specified for an option is the one used, so a users local+configuration overrides the system local version which overrides the built in+options.++# Options available++Option                    Meaning+------                    ---------------------------------------------------------------------------+_cc_                      what c compiler to use. generally this will be gcc for local builds and something like $ARCH-$HOST-gcc for cross compiles+_byteorder_               one of *le* or *be* for little or big endian+_gc_                      what garbage collector to use. It should be one of *static* or *boehm*.+_cflags_                  options to pass to the c compiler+_cflags\_debug_           options to pass to the c compiler only when debugging is enabled+_cflags\_nodebug_         options to pass to the c compiler only when debugging is disabled+_profile_                 whether to include profiling code in the generated executable+_autoload_                what haskell libraries to autoload, seperated by commas.+_executable\_extension_   specifies an extension that should be appended to executable files, (i.e. .EXE on windows)+_merge_                   a special option that merges the contents of another configuration target into the currrent one.+_bits_                    the number of bits a pointer contains on this architecture+_bits\_max_               the number of bits in the largest integral type. should be the number of bits in the 'intmax_t' C type.+_arch_                    what to pass to gcc as the architecture++# Special defines to set cflags++Define                             Meaning+------                             ---------------------------------------------------------------------------+\_JHC\_ARM\_STAY\_IN\_THUMB\_MODE  set bit0 to any function pointers, for Cortex-M*. ([more detail](http://communities.mentor.com/community/cs/archives/arm-gnu/msg01904.html))+\_JHC\_JGC\_NAIVEGC                run gc when have no more blocks.+\_JHC\_JGC\_STACKGROW              number of stack entry growed when run short of it.+\_JHC\_JGC\_FIXED\_MEGABLOCK       use a single megablock without allocation megablock.+\_JHC\_JGC\_BLOCK\_SHIFT           bit shift to specify block size. Use it internally like this: (1 << (_JHC_JGC_BLOCK_SHIFT)).+\_JHC\_JGC\_MEGABLOCK\_SHIFT       bit shift to specify megablock size. Use it internally like this: (1 << (_JHC_JGC_MEGABLOCK_SHIFT)).++-}++data Mode = BuildHl FilePath         -- ^ Build the specified hl-file given a description file.+          | Interactive              -- ^ Run interactively.+          | Version                  -- ^ Print version and die.+          | VersionCtx               -- ^ Print version context and die.+          | ShowHelp                 -- ^ Show help message and die.+          | ShowConfig               -- ^ Show configuration info.+          | CompileExe               -- ^ Compile executable+          | ShowHo String            -- ^ Show ho-file.+          | ListLibraries            -- ^ List libraries+          | PrintHscOptions          -- ^ Print options for hsc2hs+          | PurgeCache               -- ^ Purge the cache+          | Preprocess               -- ^ Filter through preprocessor+            deriving(Eq)++data StopCondition+    = StopError String         -- ^ error+    | StopParse                -- ^ Just parse and rename modules then exit+    | StopTypeCheck            -- ^ Stop after type checking+    | StopC                    -- ^ Stop after producing C code.+    | CompileHo                -- ^ Compile ho+    | StopNot                  -- ^ Don't stop believing.+            deriving(Eq)++data Opt = Opt {+    optMode        ::  Mode,      -- ^ Mode of interaction+    optColumns     :: !Int,       -- ^ Width of terminal.+    optDump        ::  [String],  -- ^ Dump options (raw).+    optStmts       ::  [String],  -- ^ statements to execute+    optFOpts       ::  [String],  -- ^ Flag options (raw).+    optIncdirs     ::  [String],  -- ^ Include directories.+    optCCargs      ::  [String],  -- ^ Optional arguments to the C compiler.+    optHls         ::  [String],  -- ^ Load the specified hl-files (haskell libraries).+    optAutoLoads   ::  [String],  -- ^ AutoLoaded haskell libraries.+    optHlPath      ::  [String],  -- ^ Path to look for libraries.+    optIncs        ::  [String],+    optDefs        ::  [String],+    optExtensions  ::  [String],+    optStop        ::  StopCondition,+    optWorkDir     ::  Maybe FilePath,+    optAnnotate    ::  Maybe FilePath,+    optDeps        ::  Maybe FilePath,+    optHoDir       ::  Maybe FilePath,+    optHoCache     ::  Maybe FilePath,+    optArgs        ::  [String],+    optStale       ::  [String],  -- ^ treat these modules as stale+    optKeepGoing   :: !Bool,      -- ^ Keep going when encountering errors.+    optMainFunc    ::  Maybe (Bool,String),    -- ^ Entry point name for the main function.+    optArch        ::  [String],           -- ^ target architecture+    optCross       ::  Bool,+    optOutName     ::  Maybe String,           -- ^ Name of output file.+    optIgnoreHo    :: !Bool,                   -- ^ Ignore ho-files.+    optNoWriteHo   :: !Bool,                   -- ^ Don't write ho-files.+    optNoAuto      :: !Bool,                   -- ^ Don't autoload packages+    optVerbose     :: !Int,                    -- ^ Verbosity+    optStatLevel   :: !Int,                    -- ^ Level to print statistics+    optInis        ::  M.Map String String,    -- ^ options read from ini files+    optDumpSet     ::  S.Set FlagDump.Flag,    -- ^ Dump flags.+    optFOptsSet    ::  S.Set FlagOpts.Flag     -- ^ Flag options (-f\<opt\>).+  } {-!derive: update !-}++emptyOpt = Opt {+    optMode        = CompileExe,+    optColumns     = getColumns,+    optCross       = False,+    optIncdirs     = initialIncludes,+    optAnnotate    = Nothing,+    optDeps        = Nothing,+    optHls         = [],+    optAutoLoads   = [],+    optHlPath      = initialLibIncludes,+    optIncs        = [],+    optDefs        = [],+    optExtensions  = [],+    optStop        = StopNot,+    optDump        = [],+    optStale       = [],+    optStmts       = [],+    optFOpts       = ["default"],+    optCCargs      = [],+    optWorkDir     = Nothing,+    optHoDir       = Nothing,+    optHoCache     = Nothing,+    optArgs        = [],+    optIgnoreHo    = False,+    optNoWriteHo   = False,+    optKeepGoing   = False,+    optMainFunc    = Nothing,+    optArch        = ["default"],+    optOutName     = Nothing,+    optVerbose     = 0,+    optStatLevel   = 1,+    optNoAuto      = False,+    optDumpSet     = S.singleton FlagDump.Progress,+    optFOptsSet    = S.empty+}++idu "-" _ = []+idu d ds = ds ++ [d]++theoptions :: [OptDescr (Opt -> Opt)]+theoptions =+    [ Option ['V'] ["version"]         (NoArg  (optMode_s Version))          "print version info and exit"+    , Option []    ["version-context"] (NoArg  (optMode_s VersionCtx))       "print version context info and exit"+    , Option []    ["help"]            (NoArg  (optMode_s ShowHelp))         "print help information and exit"+    , Option []    ["info"]            (NoArg  (optMode_s ShowConfig))       "show compiler configuration information and exit"+    , Option []    ["purge-cache"]     (NoArg  (optMode_s PurgeCache))       "clean out Ajhc compilation cache"+    , Option ['v'] ["verbose"]         (NoArg  (optVerbose_u (+1)))          "chatty output on stderr"+    , Option ['z'] []                  (NoArg  (optStatLevel_u (+1)))        "Increase verbosity of statistics"+    , Option ['d'] []                  (ReqArg (optDump_u . (:))  "[no-]flag") "dump specified data during compilation"+    , Option ['f'] []                  (ReqArg (optFOpts_u . (:)) "[no-]flag") "set or clear compilation options"+    , Option ['X'] []                  (ReqArg (optExtensions_u . (:))  "ExtensionName") "enable the given language extension"+    , Option ['o'] ["output"]          (ReqArg (optOutName_s . Just) "FILE") "output to FILE"+    , Option ['i'] ["include"]         (ReqArg (optIncdirs_u . idu) "DIR")   "where to look for source files"+    , Option ['I'] []                  (ReqArg (optIncs_u . idu) "DIR")       "add to preprocessor include path"+    , Option ['D'] []                  (ReqArg (optDefs_u . (:)) "NAME=VALUE") "add new definitions to set in preprocessor"+    , Option []    ["optc"]            (ReqArg (optCCargs_u . idu) "option") "extra options to pass to c compiler"+    , Option ['c'] []                  (NoArg  (optStop_s CompileHo))        "just compile the modules, caching the results."+    , Option ['C'] []                  (NoArg  (optStop_s StopC))            "compile to C code"+    , Option ['E'] []                  (NoArg  (optMode_s Preprocess))       "preprocess the input and print result to stdout"+    , Option ['k'] ["keepgoing"]       (NoArg  (optKeepGoing_s True))        "keep going on errors"+    , Option []    ["cross"]           (NoArg  (optCross_s True))            "enable cross-compilation, choose target with the -m flag"+    , Option []    ["stop"]            (ReqArg (optStop_s . stop) "parse/typecheck/c") "stop after the given pass, parse/typecheck/c"+    , Option []    ["width"]           (ReqArg (optColumns_s . read) "COLUMNS") "width of screen for debugging output"+    , Option []    ["main"]            (ReqArg (optMainFunc_s . Just . (,) False) "Main.main")  "main entry point"+    , Option ['m'] ["arch"]            (ReqArg (optArch_u . idu ) "arch")      "target architecture options"+    , Option []    ["entry"]           (ReqArg (optMainFunc_s . Just . (,) True)  "<expr>")  "main entry point, showable expression"+    --    , Option ['e'] []            (ReqArg (\d -> optStmts_u ( d:)) "<statement>")  "run given statement as if on jhci prompt"+    , Option []    ["show-ho"]         (ReqArg (optMode_s . ShowHo) "file.ho") "Show ho file"+    , Option []    ["noauto"]          (NoArg  (optNoAuto_s True))           "Don't automatically load base and haskell98 packages"+    , Option ['p'] []                  (ReqArg (optHls_u . (:)) "package")   "Load given haskell library package"+    , Option ['L'] []                  (ReqArg (optHlPath_u . idu) "path")   "Look for haskell libraries in the given directory"+    , Option []    ["build-hl"]        (ReqArg (optMode_s . BuildHl) "desc.yaml") "Build hakell library from given library description file"+    , Option []    ["annotate-source"] (ReqArg (optAnnotate_s . Just) "<dir>") "Write preprocessed and annotated source code to the directory specified"+    , Option []    ["deps"]            (ReqArg (optDeps_s . Just) "<file.yaml>") "Write dependency information to file specified"+    , Option []    ["interactive"]     (NoArg  (optMode_s Interactive))      "run interactivly                                                             ( for debugging only)"+    , Option []    ["ignore-cache"]    (NoArg  (optIgnoreHo_s True))         "Ignore existing compilation cache entries."+    , Option []    ["readonly-cache"]  (NoArg  (optNoWriteHo_s True))        "Do not write new information to the compilation cache."+    , Option []    ["no-cache"]        (NoArg  (optNoWriteHo_s True . optIgnoreHo_s True)) "Do not use or update the cache."+    , Option []    ["cache-dir"]       (ReqArg (optHoCache_s . Just ) "AJHC_CACHE")  "Use a global cache located in the directory passed as an argument."+--    , Option []    ["ho-dir"]          (ReqArg (optHoDir_s . Just ) "<dir>")    "Where to place and look for ho files"+    , Option []    ["stale"]           (ReqArg (optStale_u . idu) "Module")  "Treat these modules as stale, even if they exist in the cache"+    , Option []    ["list-libraries"]  (NoArg  (optMode_s ListLibraries))    "List of installed libraries"+    , Option []    ["tdir"]            (ReqArg (optWorkDir_s . Just) "dir/") "specify the directory where all intermediate files/dumps will be placed."+--    , Option []    ["print-hsc-options"] (NoArg (optMode_s PrintHscOptions)) "print options to pass to hsc2hs"+    ]++stop "parse" = StopParse+stop "deps" = StopParse+stop "typecheck" = StopTypeCheck+stop "c" = StopC+stop s = StopError s++-- | Width of terminal.+getColumns :: Int+getColumns = read $ unsafePerformIO (getEnv "COLUMNS" `mplus` return "80")++postProcessFD :: Monad m => Opt -> m Opt+postProcessFD o = case FlagDump.process (optDumpSet o) (optDump o ++ vv) of+        (s,[]) -> return $ o { optDumpSet = s, optDump = [] }+        (_,xs) -> fail ("Unrecognized dump flag passed to '-d': "+                        ++ unwords xs ++ "\nValid dump flags:\n\n" ++ FlagDump.helpMsg)+    where+    vv | optVerbose o >= 2 = ["veryverbose"]+       | optVerbose o >= 1 = ["verbose"]+       | otherwise = []++postProcessFO :: Monad m => Opt -> m Opt+postProcessFO o = case FlagOpts.process (optFOptsSet o) (optFOpts o) of+        (s,[]) -> return $ o { optFOptsSet = s, optFOpts = [] }+        (_,xs) -> fail ("Unrecognized flag passed to '-f': "+                        ++ unwords xs ++ "\nValid flags:\n\n" ++ FlagOpts.helpMsg)++getArguments = do+    x <- lookupEnv "AJHC_OPTS"+    let eas = maybe [] words x+    as <- getArgs+    return (eas ++ as)++pfill ::+    Int            -- ^ maximum width+    -> (a -> Int)  -- ^ find width of any element+    -> [a]         -- ^ input elements+    -> [[a]]       -- ^ output element+pfill maxn length xs = f maxn xs [] [] where+    f n (x:xs) ws ls | lx < n = f (n - lx) xs (x:ws) ls where+        lx = length x+    f _ (x:xs) [] ls = f (maxn - length x) xs [x] ls+    f _ (x:xs) ws ls = f (maxn - length x) xs [x] (ws:ls)+    f _ [] [] ls = reverse (map reverse ls)+    f _ [] ws ls = reverse (map reverse (ws:ls))++helpUsage = usageInfo header theoptions ++ trailer where+    header = "Usage: ajhc [OPTION...] Main.hs"+    trailer = "\n" ++ mkoptlist "-d" FlagDump.helpFlags ++ "\n" ++ mkoptlist "-f" FlagOpts.helpFlags+    mkoptlist d os = "valid " ++ d ++ " arguments: 'help' for more info\n    " ++ intercalate "\n    " (map (intercalate ", ") $ pfill 100 ((2 +) . length) os) ++ "\n"++{-# NOINLINE processOptions #-}+-- | Parse commandline options.+processOptions :: IO Opt+processOptions = do+    -- initial argument processing+    argv <- getArguments+    let (o,ns,rc) = getOpt Permute theoptions argv+    o <- return (foldl (flip ($)) emptyOpt o)+    when (rc /= []) $ putErrLn (concat rc ++ helpUsage) >> exitWith exitCodeUsage+    case optStop o of+        StopError s -> putErrLn "bad option passed to --stop should be one of parse, deps, typecheck, or c" >> exitWith exitCodeUsage+        _ -> return ()+    case optMode o of+        ShowHelp    -> doShowHelp+        ShowConfig  -> doShowConfig+        Version     -> putStrLn versionString >> exitSuccess+        VersionCtx  -> putStrLn (versionString ++ BS.toString versionContext) >> exitSuccess+        PrintHscOptions -> do+            putStrLn $ "-I" ++ VC.datadir ++ "/" ++ VC.package ++ "-" ++ VC.shortVersion ++ "/include"+            exitSuccess+        _ -> return ()+    -- read targets.ini file+    Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME"+    inis <- parseIniFiles (optVerbose o > 0) (BS.toString targets_ini) [confDir ++ "/targets.ini", confDir ++ "/targets-local.ini", home ++ "/etc/ajhc/targets.ini", home ++ "/.ajhc/targets.ini"] (optArch o)+    -- process dump flags+    o <- either putErrDie return $ postProcessFD o+    when (FlagDump.Ini `S.member` optDumpSet o) $ flip mapM_ (M.toList inis) $ \(a,b) -> putStrLn (a ++ "=" ++ b)+    -- set flags based on ini options+    let o1 = case M.lookup "gc" inis of+            Just "jgc" -> optFOptsSet_u (S.insert FlagOpts.Jgc) o+            Just "boehm" -> optFOptsSet_u (S.insert FlagOpts.Boehm) o+            _ -> o+    o2 <- either putErrDie return $ postProcessFO o1+    when (FlagDump.Ini `S.member` optDumpSet o) $ do+        putStrLn (show $ optDumpSet o)+        putStrLn (show $ optFOptsSet o)+    -- add autoloads based on ini options+    let autoloads = maybe [] (tokens (',' ==)) (M.lookup "autoload" inis)+    return o2 { optArgs = ns, optInis = inis, optAutoLoads = autoloads }++doShowHelp = do+    putStrLn helpUsage+    exitSuccess++doShowConfig = do+    --mapM_ (\ (x,y) -> putStrLn (x ++ ": " ++ y))  configs+    putStrLn $ showYAML  configs+    exitSuccess++findHoCache :: IO (Maybe FilePath)+findHoCache = do+    cd <- lookupEnv "AJHC_CACHE"+    case optHoCache options `mplus` cd of+        Just s -> do return (Just s)+        Just "-" -> do return Nothing+        Nothing | isNothing (optHoDir options) -> do+            Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME"+            let cd = home ++ "/.ajhc/cache"+            createDirectoryIfMissing True cd+            return (Just cd)+        _  -> return Nothing++configs :: Node+configs = toNode [+    "jhclibpath" ==> initialLibIncludes,+    "version" ==> version,+    "package" ==> package,+    "libdir" ==> libdir,+    "datadir" ==> datadir,+    "libraryInstall" ==> libraryInstall,+    "host" ==> host+    ] where+    (==>) :: ToNode b => String -> b -> (String,Node)+    a ==> b = (a,toNode b)++{-# NOINLINE fileOptions #-}+fileOptions :: Monad m => Opt -> [String] -> m Opt+fileOptions options xs = case getOpt Permute theoptions xs of+    (os,[],[]) -> postProcessFD (foldl (flip ($)) options os) >>= postProcessFO+    (_,_,errs) -> fail (concat errs)++{-# NOINLINE options #-}+-- | The global options currently used.+options :: Opt+options = unsafePerformIO processOptions++-- | Put a string to stderr when running verbose.+putVerbose :: String -> IO ()+putVerbose s = when (optVerbose options > 0) $ putErr s++-- | Put a line to stderr when running verbose.+putVerboseLn :: String -> IO ()+putVerboseLn s = putVerbose (s ++ "\n")++putProgress :: String -> IO ()+putProgress s = when progress $ putErr s++-- | Put a line to stderr when running verbose.+putProgressLn :: String -> IO ()+putProgressLn s = putProgress (s ++ "\n")++-- | Is verbose > 0?+progress :: Bool+progress = dump FlagDump.Progress++-- | Is verbose > 0?+verbose :: Bool+verbose = optVerbose options > 0+-- | Is verbose > 1?+verbose2 :: Bool+verbose2 = optVerbose options > 1++-- | Test whether a dump flag is set.+dump :: FlagDump.Flag -> Bool+dump s = s `S.member` optDumpSet options+-- | Test whether an option flag is set.+fopts :: FlagOpts.Flag -> Bool+fopts s = s `S.member` optFOptsSet options+-- | Do the action when the suplied dump flag is set.+wdump :: (Monad m) => FlagDump.Flag -> m () -> m ()+wdump f = when (dump f)++-- | Is the \"lint\" option flag set?+flint :: Bool+flint = FlagOpts.Lint `S.member` optFOptsSet options++-- | Include directories taken from JHCPATH enviroment variable.+initialIncludes :: [String]+initialIncludes = unsafePerformIO $ do+    p <- lookupEnv "AJHC_PATH"+    let x = fromMaybe "" p+    return (".":(tokens (== ':') x))++-- | Include directories taken from JHCLIBPATH enviroment variable.+initialLibIncludes :: [String]+initialLibIncludes = unsafePerformIO $ do+    ps <- lookupEnv "AJHC_LIBRARY_PATH"+    h <- lookupEnv "HOME"+    let paths = h ++ ["/usr/local","/usr"]+        bases = ["/lib","/share"]+        vers = ["/ajhc-" ++ shortVersion, "/ajhc"]+    dat <- getDataFileNameMaybe "lib"+    return $ nub $ maybe [] (tokens (':' ==))  ps ++ [ p ++ b ++ v | p <- paths, v <- vers, b <- bases ]+               ++ [d ++ v | d <- [libdir,datadir], v <- vers] ++ [libraryInstall] ++ maybeToList dat++class Monad m => OptionMonad m where+    getOptions :: m Opt+    getOptions = return options++instance OptionMonad Identity++newtype OptT m a = OptT (ReaderT Opt m a)+    deriving(MonadIO,Monad,Functor,MonadTrans)++type OptM = OptT Identity++instance Monad m => OptionMonad (OptT m) where+    getOptions = OptT ask++withOptions :: Opt -> OptM a -> a+withOptions opt (OptT x) = runIdentity (runReaderT x opt)++withOptionsT :: Opt -> OptT m a -> m a+withOptionsT opt (OptT x) = runReaderT x opt++outputName = fromMaybe "hs.out" (optOutName options)++flagOpt :: OptionMonad m => FlagOpts.Flag -> m Bool+flagOpt flag = do+    opt <- getOptions+    return (flag `S.member` optFOptsSet opt)++getArgString = do+    name <- getProgName+    args <- getArguments+    return (simpleQuote (name:args),head $ lines versionString)+{-* Generated by DrIFT : Look, but Don't Touch. *-}+optAnnotate_u f r@Opt{optAnnotate  = x} = r{optAnnotate = f x}+optArch_u f r@Opt{optArch  = x} = r{optArch = f x}+optArgs_u f r@Opt{optArgs  = x} = r{optArgs = f x}+optAutoLoads_u f r@Opt{optAutoLoads  = x} = r{optAutoLoads = f x}+optCCargs_u f r@Opt{optCCargs  = x} = r{optCCargs = f x}+optColumns_u f r@Opt{optColumns  = x} = r{optColumns = f x}+optCross_u f r@Opt{optCross  = x} = r{optCross = f x}+optDefs_u f r@Opt{optDefs  = x} = r{optDefs = f x}+optDeps_u f r@Opt{optDeps  = x} = r{optDeps = f x}+optDump_u f r@Opt{optDump  = x} = r{optDump = f x}+optDumpSet_u f r@Opt{optDumpSet  = x} = r{optDumpSet = f x}+optExtensions_u f r@Opt{optExtensions  = x} = r{optExtensions = f x}+optFOpts_u f r@Opt{optFOpts  = x} = r{optFOpts = f x}+optFOptsSet_u f r@Opt{optFOptsSet  = x} = r{optFOptsSet = f x}+optHlPath_u f r@Opt{optHlPath  = x} = r{optHlPath = f x}+optHls_u f r@Opt{optHls  = x} = r{optHls = f x}+optHoCache_u f r@Opt{optHoCache  = x} = r{optHoCache = f x}+optHoDir_u f r@Opt{optHoDir  = x} = r{optHoDir = f x}+optIgnoreHo_u f r@Opt{optIgnoreHo  = x} = r{optIgnoreHo = f x}+optIncdirs_u f r@Opt{optIncdirs  = x} = r{optIncdirs = f x}+optIncs_u f r@Opt{optIncs  = x} = r{optIncs = f x}+optInis_u f r@Opt{optInis  = x} = r{optInis = f x}+optKeepGoing_u f r@Opt{optKeepGoing  = x} = r{optKeepGoing = f x}+optMainFunc_u f r@Opt{optMainFunc  = x} = r{optMainFunc = f x}+optMode_u f r@Opt{optMode  = x} = r{optMode = f x}+optNoAuto_u f r@Opt{optNoAuto  = x} = r{optNoAuto = f x}+optNoWriteHo_u f r@Opt{optNoWriteHo  = x} = r{optNoWriteHo = f x}+optOutName_u f r@Opt{optOutName  = x} = r{optOutName = f x}+optStale_u f r@Opt{optStale  = x} = r{optStale = f x}+optStatLevel_u f r@Opt{optStatLevel  = x} = r{optStatLevel = f x}+optStmts_u f r@Opt{optStmts  = x} = r{optStmts = f x}+optStop_u f r@Opt{optStop  = x} = r{optStop = f x}+optVerbose_u f r@Opt{optVerbose  = x} = r{optVerbose = f x}+optWorkDir_u f r@Opt{optWorkDir  = x} = r{optWorkDir = f x}+optAnnotate_s v =  optAnnotate_u  (const v)+optArch_s v =  optArch_u  (const v)+optArgs_s v =  optArgs_u  (const v)+optAutoLoads_s v =  optAutoLoads_u  (const v)+optCCargs_s v =  optCCargs_u  (const v)+optColumns_s v =  optColumns_u  (const v)+optCross_s v =  optCross_u  (const v)+optDefs_s v =  optDefs_u  (const v)+optDeps_s v =  optDeps_u  (const v)+optDump_s v =  optDump_u  (const v)+optDumpSet_s v =  optDumpSet_u  (const v)+optExtensions_s v =  optExtensions_u  (const v)+optFOpts_s v =  optFOpts_u  (const v)+optFOptsSet_s v =  optFOptsSet_u  (const v)+optHlPath_s v =  optHlPath_u  (const v)+optHls_s v =  optHls_u  (const v)+optHoCache_s v =  optHoCache_u  (const v)+optHoDir_s v =  optHoDir_u  (const v)+optIgnoreHo_s v =  optIgnoreHo_u  (const v)+optIncdirs_s v =  optIncdirs_u  (const v)+optIncs_s v =  optIncs_u  (const v)+optInis_s v =  optInis_u  (const v)+optKeepGoing_s v =  optKeepGoing_u  (const v)+optMainFunc_s v =  optMainFunc_u  (const v)+optMode_s v =  optMode_u  (const v)+optNoAuto_s v =  optNoAuto_u  (const v)+optNoWriteHo_s v =  optNoWriteHo_u  (const v)+optOutName_s v =  optOutName_u  (const v)+optStale_s v =  optStale_u  (const v)+optStatLevel_s v =  optStatLevel_u  (const v)+optStmts_s v =  optStmts_u  (const v)+optStop_s v =  optStop_u  (const v)+optVerbose_s v =  optVerbose_u  (const v)+optWorkDir_s v =  optWorkDir_u  (const v)++--  Imported from other files :-
+ examples/BinaryTrees.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -fglasgow-exts -O2 -optc-O3 -funbox-strict-fields #-}+-- The Great Computer Language Shootout+-- http://shootout.alioth.debian.org/+-- Simon Marlow+-- Shortened by Don Stewart+-- De-optimized by Isaac Gouy++import System; import Text.Printf; import Control.Monad++data Tree = Nil | Node !Int Tree Tree++min' = 4 :: Int++main = do max' <- getArgs >>= return . max (min'+2) . read . head+          printf "stretch tree of depth %d\t check: %d\n" (max'+1) (itemCheck $ make 0 (max'+1))+          depthLoop min' max'+          printf "long lived tree of depth %d\t check: %d\n" max' (itemCheck $ make 0 max')++depthLoop :: Int -> Int -> IO ()+depthLoop d m = when (d <= m) $ do+        printf "%d\t trees of depth %d\t check: %d\n" (2*n) d (sumLoop n d 0)+        depthLoop (d+2) m+    where n = 2^(m - d + min')++sumLoop 0 d acc = acc+sumLoop k d acc = c `seq` sumLoop (k-1) d (acc + c + c')+    where (c,c')  = (itemCheck (make k d), itemCheck (make (-1*k) d))++-- make i (0::Int) = i `seq` Nil+make :: Int -> Int -> Tree+make i 0 = Node i Nil Nil+make i d = Node i (make ((2*i)-1) (d-1)) (make (2*i) (d-1))++itemCheck Nil = 0+itemCheck (Node x l r) = x + itemCheck l - itemCheck r
+ examples/Calendar.hs view
@@ -0,0 +1,136 @@+-- This is a modification of the calendar program described in section 4.5+-- of Bird and Wadler's ``Introduction to functional programming'', with+-- two ways of printing the calendar ... as in B+W, or like UNIX `cal':++import System.IO -- 1.3+import System -- 1.3+import Data.List -- 1.3+import Data.Char -- 1.3+++-- Picture handling:++infixr 5 `above`, `beside`++type Picture   =  [[Char]]++height, width :: Picture -> Int+height p       = length p+width  p       = length (head p)++above, beside :: Picture -> Picture -> Picture+above          = (++)+beside         = zipWith (++)++stack, spread :: [Picture] -> Picture+stack          = foldr1 above+spread         = foldr1 beside++empty         :: (Int,Int) -> Picture+empty (h,w)    = copy h (copy w ' ')++block, blockT :: Int -> [Picture] -> Picture+block n        = stack . map spread . groop n+blockT n       = spread . map stack . groop n++groop         :: Int -> [a] -> [[a]]+groop n []     = []+groop n xs     = take n xs : groop n (drop n xs)++lframe        :: (Int,Int) -> Picture -> Picture+lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)+		 where h = height p+                       w = width p++-- Information about the months in a year:++monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]+                    where feb | leap year = 29+                              | otherwise = 28++leap year         = if year`mod`100 == 0 then year`mod`400 == 0+                                         else year`mod`4   == 0++monthNames        = ["January","February","March","April",+		     "May","June","July","August",+		     "September","October","November","December"]++jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7+                    where last = year - 1++firstDays year    = take 12+                         (map (`mod`7)+                              (scanl (+) (jan1st year) (monthLengths year)))++-- Producing the information necessary for one month:++dates fd ml = map (date ml) [1-fd..42-fd]+              where date ml d | d<1 || ml<d  = ["   "]+                              | otherwise    = [rjustify 3 (show d)]++-- The original B+W calendar:++calendar :: Int -> String+calendar  = unlines . block 3 . map picture . months+            where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml+                  title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]+                  table fd ml    = lframe (8,25)+                                          (daynames `beside` entries fd ml)+                  daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]+                  entries fd ml  = blockT 7 (dates fd ml)+                  months year    = zip4 monthNames+                                        (copy 12 year)+                                        (firstDays year)+                                        (monthLengths year)++-- In a format somewhat closer to UNIX cal:++cal year = unlines (banner year `above` body year)+           where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)+                 body           = block 3 . map (pad . pic) . months+                 pic (mn,fd,ml) = title mn `above` table fd ml+                 pad p          = (side`beside`p`beside`side)`above`end+                 side           = empty (8,2)+                 end            = empty (1,25)+                 title mn       = [cjustify 21 mn]+                 table fd ml    = daynames `above` entries fd ml+                 daynames       = [" Su Mo Tu We Th Fr Sa"]+                 entries fd ml  = block 7 (dates fd ml)+                 months year    = zip3 monthNames+                                       (firstDays year)+                                       (monthLengths year)++-- For a standalone calendar program:++main = do+    strs <- getArgs+    case strs of [year] -> calFor year+                 _      -> fail ("Usage: cal year\n")+++calFor year | illFormed = fail ("Bad argument: " ++ show year ++ show ds ++ show rs ++ show yr)+            | otherwise = putStr (cal yr)+              where illFormed = null ds || not (null rs)+                    (ds,rs)   = span isDigit year+                    yr        = atoi ds+                    atoi s    = foldl (\a d -> 10*a+d) 0 (map toDigit s)+                    toDigit d = fromEnum d - fromEnum '0'+++-- End of calendar program++-- tacked on by partain+copy    :: Int -> a -> [a]+copy n x = take n (repeat x)++cjustify, ljustify, rjustify :: Int -> String -> String++cjustify n s = space halfm ++ s ++ space (m - halfm)+               where m     = n - length s+                     halfm = m `div` 2+ljustify n s = s ++ space (n - length s)+rjustify n s = space (n - length s) ++ s++space       :: Int -> String+space n      = copy n ' '+-- end of tack
+ examples/Forall.hs view
@@ -0,0 +1,87 @@+module Main where++-- Test program for various uses of higher order polymorphism++-- useful bits+newtype Id x = Id x+--    deriving(Show)++-- interesting haskell 98 types+newtype Rec f = In (f (Rec f))+newtype StateM m s a = STM (a -> m (a,s))+newtype Bot = Bot Bot+    deriving(Show)++-- other stuff++-- TODO this causes segfault when shown+data Empty+++-- forall in type synonym+type IdentityFunc = forall a . a -> a++type Arg2 f b = f b++type IO' a = IO a++-- explicit forall+id1 :: forall a . a -> a+id1 x = x+++-- type synonym with forall+id2 :: IdentityFunc+id2 x = x+++++-- forall hoisting+id3 :: a -> IdentityFunc+id3 _ x = x++-- ghc does not accept the following 2 without the parens++id4 :: a -> (forall a . a -> a)+id4 _ x = x++id5 :: a -> (forall b . (forall c . (forall d . b -> c -> d -> a)))+id5 a _ _ _ = a++id6 :: a -> (forall b . Show b => (forall d . (Eq b, Show d) => (b,d)))+id6 = undefined++-- this should be rejected.+--id3 :: forall a . b -> a -> a+--id3 _ x = x++-- synonyms may be partially applied in arguments to other type synonyms+synPart :: Arg2 IO' Int+synPart = undefined++-- incomplete partially applied synonym. should be rejected+--synPart' :: Arg2 IO+--synPart' = undefined+++-- polymorphic components+data Bob  = Bob (forall a . a -> a)++-- this can't be handled yet+data Fred = Fred (forall a . a -> a) ((forall a . (forall b . b -> a ) -> a) -> Int)++xs :: [forall a . a -> a]+xs = [id,const undefined,error "three"]++myhead ::  [forall a . a -> a] -> (forall a . a -> a)+myhead = head++f (Bob x) = (x 'y',x (3::Int))++main = do+    putChar $ fst $ f (Bob id)+    putChar $ myhead xs 'z'+    putStrLn "Done."++
+ examples/HelloWorld.hs view
@@ -0,0 +1,2 @@++main = putStrLn "Hello, World!"
+ examples/Options.hs view
@@ -0,0 +1,18 @@++import Jhc.Options+import Text.Printf++main :: IO ()+main = do+    printf "isWindows:      %s\n" (show isWindows)+    printf "isPosix:        %s\n" (show isPosix)+    printf "isBigEndian:    %s\n" (show isBigEndian)+    printf "isLittleEndian: %s\n" (show isLittleEndian)+    printf "Target:         %s\n" (show target)+++instance Show Target where+    show Grin = "Grin"+    show GhcHs = "GhcHs"+    show DotNet = "DotNet"+    show Java = "Java"
+ examples/Primes.hs view
@@ -0,0 +1,23 @@++suCC :: Int -> Int+suCC x = x + 1++isdivs :: Int  -> Int -> Bool+isdivs n x = mod x n /= 0++--the_filter :: [Int] -> [Int]+--the_filter (n:ns) = filter (isdivs n) ns++the_filter :: [Int] -> [Int]+the_filter (n:ns) = f ns where+    f [] = []+    f (x:ns) | isdivs n x = (x:f ns)+    f (_:ns) = f ns++primes :: [Int]+primes = map head (iterate the_filter (iterate suCC 2))+--primes = map head (iterate the_filter [2 .. ])++main = do+	--[arg] <- getArgs+	print $ primes !! 2000 -- (read arg)
+ lib/applicative/Control/Applicative.hs view
@@ -0,0 +1,221 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Applicative+-- Copyright   :  Conor McBride and Ross Paterson 2005+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- This module describes a structure intermediate between a functor and+-- a monad: it provides pure expressions and sequencing, but no binding.+-- (Technically, a strong lax monoidal functor.)  For more details, see+-- /Applicative Programming with Effects/,+-- by Conor McBride and Ross Paterson, online at+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+-- This interface was introduced for parsers by Niklas R&#xF6;jemo, because+-- it admits more sharing than the monadic interface.  The names here are+-- mostly based on recent parsing work by Doaitse Swierstra.+--+-- This class is also useful with instances of the+-- 'Data.Traversable.Traversable' class.++module Control.Applicative (+        -- * Applicative functors+        Applicative(..),+        -- * Alternatives+        Alternative(..),+        -- * Instances+        Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),+        -- * Utility functions+        (<$>), (<$), (*>), (<*), (<**>),+        liftA, liftA2, liftA3,+        optional, some, many+        ) where++import Prelude hiding (id,(.))+import qualified Prelude++import Data.Functor+import Control.Category+import Control.Arrow+        (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>)))+import Control.Monad (liftM, ap, MonadPlus(..))+import Control.Monad.Instances ()+import Data.Monoid (Monoid(..))++infixl 3 <|>+infixl 4 <$>, <$+infixl 4 <*>, <*, *>, <**>++-- | A functor with application.+--+-- Instances should satisfy the following laws:+--+-- [/identity/]+--      @'pure' 'id' '<*>' v = v@+--+-- [/composition/]+--      @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@+--+-- [/homomorphism/]+--      @'pure' f '<*>' 'pure' x = 'pure' (f x)@+--+-- [/interchange/]+--      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@+--+-- The 'Functor' instance should satisfy+--+-- @+--      'fmap' f x = 'pure' f '<*>' x+-- @+--+-- If @f@ is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@.++class Functor f => Applicative f where+        -- | Lift a value.+        pure :: a -> f a++        -- | Sequential application.+        (<*>) :: f (a -> b) -> f a -> f b++-- | A monoid on applicative functors.+class Applicative f => Alternative f where+        -- | The identity of '<|>'+        empty :: f a+        -- | An associative binary operation+        (<|>) :: f a -> f a -> f a++-- instances for Prelude types++instance Applicative Maybe where+        pure = return+        (<*>) = ap++instance Alternative Maybe where+        empty = Nothing+        Nothing <|> p = p+        Just x <|> _ = Just x++instance Applicative [] where+        pure = return+        (<*>) = ap++instance Alternative [] where+        empty = []+        (<|>) = (++)++instance Applicative IO where+        pure = return+        (<*>) = ap++instance Applicative ((->) a) where+        pure = const+        (<*>) f g x = f x (g x)++instance Monoid a => Applicative ((,) a) where+        pure x = (mempty, x)+        (u, f) <*> (v, x) = (u `mappend` v, f x)++-- new instances++newtype Const a b = Const { getConst :: a }++instance Functor (Const m) where+        fmap _ (Const v) = Const v++instance Monoid m => Applicative (Const m) where+        pure _ = Const mempty+        Const f <*> Const v = Const (f `mappend` v)++newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }++instance Monad m => Functor (WrappedMonad m) where+        fmap f (WrapMonad v) = WrapMonad (liftM f v)++instance Monad m => Applicative (WrappedMonad m) where+        pure = WrapMonad . return+        WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)++instance MonadPlus m => Alternative (WrappedMonad m) where+        empty = WrapMonad mzero+        WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)++newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }++instance Arrow a => Functor (WrappedArrow a b) where+        fmap f (WrapArrow a) = WrapArrow (a >>> arr f)++instance Arrow a => Applicative (WrappedArrow a b) where+        pure x = WrapArrow (arr (const x))+        WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))++instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where+        empty = WrapArrow zeroArrow+        WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)++-- | Lists, but with an 'Applicative' functor based on zipping, so that+--+-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@+--+newtype ZipList a = ZipList { getZipList :: [a] }++instance Functor ZipList where+        fmap f (ZipList xs) = ZipList (map f xs)++instance Applicative ZipList where+        pure x = ZipList (repeat x)+        ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)++-- extra functions++-- | A synonym for 'fmap'.+--(<$>) :: Functor f => (a -> b) -> f a -> f b+--f <$> a = fmap f a++-- | Replace the value.+--(<$) :: Functor f => a -> f b -> f a+--(<$) = (<$>) . const++-- | Sequence actions, discarding the value of the first argument.+(*>) :: Applicative f => f a -> f b -> f b+(*>) = liftA2 (const id)++-- | Sequence actions, discarding the value of the second argument.+(<*) :: Applicative f => f a -> f b -> f a+(<*) = liftA2 const++-- | A variant of '<*>' with the arguments reversed.+(<**>) :: Applicative f => f a -> f (a -> b) -> f b+(<**>) = liftA2 (flip ($))++-- | Lift a function to actions.+-- This function may be used as a value for `fmap` in a `Functor` instance.+liftA :: Applicative f => (a -> b) -> f a -> f b+liftA f a = pure f <*> a++-- | Lift a binary function to actions.+liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c+liftA2 f a b = f <$> a <*> b++-- | Lift a ternary function to actions.+liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d+liftA3 f a b c = f <$> a <*> b <*> c++-- | One or none.+optional :: Alternative f => f a -> f (Maybe a)+optional v = Just <$> v <|> pure Nothing++-- | One or more.+some :: Alternative f => f a -> f [a]+some v = some_v+  where many_v = some_v <|> pure []+        some_v = (:) <$> v <*> many_v++-- | Zero or more.+many :: Alternative f => f a -> f [a]+many v = many_v+  where many_v = some_v <|> pure []+        some_v = (:) <$> v <*> many_v
+ lib/applicative/Control/Arrow.hs view
@@ -0,0 +1,280 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Arrow+-- Copyright   :  (c) Ross Paterson 2002+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Basic arrow definitions, based on+--      /Generalising Monads to Arrows/, by John Hughes,+--      /Science of Computer Programming/ 37, pp67-111, May 2000.+-- plus a couple of definitions ('returnA' and 'loop') from+--      /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,+--      Firenze, Italy, pp229-240.+-- See these papers for the equations these combinators are expected to+-- satisfy.  These papers and more information on arrows can be found at+-- <http://www.haskell.org/arrows/>.++module Control.Arrow (+                -- * Arrows+                Arrow(..), Kleisli(..),+                -- ** Derived combinators+                returnA,+                (^>>), (>>^),+                -- ** Right-to-left variants+                (<<^), (^<<),+                -- * Monoid operations+                ArrowZero(..), ArrowPlus(..),+                -- * Conditionals+                ArrowChoice(..),+                -- * Arrow application+                ArrowApply(..), ArrowMonad(..), leftApp,+                -- * Feedback+                ArrowLoop(..)+        ) where++import Prelude hiding (id,(.))+import qualified Prelude++import Control.Monad+import Control.Monad.Fix+import Control.Category++infixr 5 <+>+infixr 3 ***+infixr 3 &&&+infixr 2 ++++infixr 2 |||+infixr 1 ^>>, >>^+infixr 1 ^<<, <<^++-- | The basic arrow class.+--   Any instance must define either 'arr' or 'pure' (which are synonyms),+--   as well as 'first'.  The other combinators have sensible+--   default definitions, which may be overridden for efficiency.++class Category a => Arrow a where++        -- | Lift a function to an arrow: you must define either this+        --   or 'pure'.+        arr :: (b -> c) -> a b c+        arr = pure++        -- | A synonym for 'arr': you must define one or other of them.+        pure :: (b -> c) -> a b c+        pure = arr++        -- | Send the first component of the input through the argument+        --   arrow, and copy the rest unchanged to the output.+        first :: a b c -> a (b,d) (c,d)++        -- | A mirror image of 'first'.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        second :: a b c -> a (d,b) (d,c)+        second f = arr swap >>> first f >>> arr swap+                        where   swap ~(x,y) = (y,x)++        -- | Split the input between the two argument arrows and combine+        --   their output.  Note that this is in general not a functor.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        (***) :: a b c -> a b' c' -> a (b,b') (c,c')+        f *** g = first f >>> second g++        -- | Fanout: send the input to both argument arrows and combine+        --   their output.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        (&&&) :: a b c -> a b c' -> a b (c,c')+        f &&& g = arr (\b -> (b,b)) >>> f *** g++{-# RULES+"identity"+                arr id = id+"compose/arr"   forall f g .+                (arr f) . (arr g) = arr (f . g)+"first/arr"     forall f .+                first (arr f) = arr (first f)+"second/arr"    forall f .+                second (arr f) = arr (second f)+"product/arr"   forall f g .+                arr f *** arr g = arr (f *** g)+"fanout/arr"    forall f g .+                arr f &&& arr g = arr (f &&& g)+"compose/first" forall f g .+                (first f) . (first g) = first (f . g)+"compose/second" forall f g .+                (second f) . (second g) = second (f . g)+ #-}++-- Ordinary functions are arrows.++instance Arrow (->) where+        arr f = f+        first f = f *** id+        second f = id *** f+--      (f *** g) ~(x,y) = (f x, g y)+--      sorry, although the above defn is fully H'98, nhc98 can't parse it.+        (***) f g ~(x,y) = (f x, g y)++-- | Kleisli arrows of a monad.++newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }++instance Monad m => Category (Kleisli m) where+        id = Kleisli return+        (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)++instance Monad m => Arrow (Kleisli m) where+        arr f = Kleisli (return . f)+        first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d))+        second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))++-- | The identity arrow, which plays the role of 'return' in arrow notation.++returnA :: Arrow a => a b b+returnA = arr id++-- | Precomposition with a pure function.+(^>>) :: Arrow a => (b -> c) -> a c d -> a b d+f ^>> a = arr f >>> a++-- | Postcomposition with a pure function.+(>>^) :: Arrow a => a b c -> (c -> d) -> a b d+a >>^ f = a >>> arr f++-- | Precomposition with a pure function (right-to-left variant).+(<<^) :: Arrow a => a c d -> (b -> c) -> a b d+a <<^ f = a <<< arr f++-- | Postcomposition with a pure function (right-to-left variant).+(^<<) :: Arrow a => (c -> d) -> a b c -> a b d+f ^<< a = arr f <<< a++class Arrow a => ArrowZero a where+        zeroArrow :: a b c++instance MonadPlus m => ArrowZero (Kleisli m) where+        zeroArrow = Kleisli (\x -> mzero)++class ArrowZero a => ArrowPlus a where+        (<+>) :: a b c -> a b c -> a b c++instance MonadPlus m => ArrowPlus (Kleisli m) where+        Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)++-- | Choice, for arrows that support it.  This class underlies the+--   @if@ and @case@ constructs in arrow notation.+--   Any instance must define 'left'.  The other combinators have sensible+--   default definitions, which may be overridden for efficiency.++class Arrow a => ArrowChoice a where++        -- | Feed marked inputs through the argument arrow, passing the+        --   rest through unchanged to the output.+        left :: a b c -> a (Either b d) (Either c d)++        -- | A mirror image of 'left'.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        right :: a b c -> a (Either d b) (Either d c)+        right f = arr mirror >>> left f >>> arr mirror+                        where   mirror (Left x) = Right x+                                mirror (Right y) = Left y++        -- | Split the input between the two argument arrows, retagging+        --   and merging their outputs.+        --   Note that this is in general not a functor.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')+        f +++ g = left f >>> right g++        -- | Fanin: Split the input between the two argument arrows and+        --   merge their outputs.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        (|||) :: a b d -> a c d -> a (Either b c) d+        f ||| g = f +++ g >>> arr untag+                        where   untag (Left x) = x+                                untag (Right y) = y++{-# RULES+"left/arr"      forall f .+                left (arr f) = arr (left f)+"right/arr"     forall f .+                right (arr f) = arr (right f)+"sum/arr"       forall f g .+                arr f +++ arr g = arr (f +++ g)+"fanin/arr"     forall f g .+                arr f ||| arr g = arr (f ||| g)+"compose/left"  forall f g .+                left f >>> left g = left (f >>> g)+"compose/right" forall f g .+                right f >>> right g = right (f >>> g)+ #-}++instance ArrowChoice (->) where+        left f = f +++ id+        right f = id +++ f+        f +++ g = (Left . f) ||| (Right . g)+        (|||) = either++instance Monad m => ArrowChoice (Kleisli m) where+        left f = f +++ arr id+        right f = arr id +++ f+        f +++ g = (f >>> arr Left) ||| (g >>> arr Right)+        Kleisli f ||| Kleisli g = Kleisli (either f g)++-- | Some arrows allow application of arrow inputs to other inputs.++class Arrow a => ArrowApply a where+        app :: a (a b c, b) c++instance ArrowApply (->) where+        app (f,x) = f x++instance Monad m => ArrowApply (Kleisli m) where+        app = Kleisli (\(Kleisli f, x) -> f x)++-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise+--   to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.++newtype ArrowMonad a b = ArrowMonad (a () b)++instance ArrowApply a => Monad (ArrowMonad a) where+        return x = ArrowMonad (arr (\z -> x))+        ArrowMonad m >>= f = ArrowMonad (m >>>+                        arr (\x -> let ArrowMonad h = f x in (h, ())) >>>+                        app)++-- | Any instance of 'ArrowApply' can be made into an instance of+--   'ArrowChoice' by defining 'left' = 'leftApp'.++leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)+leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||+                 (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app++-- | The 'loop' operator expresses computations in which an output value is+--   fed back as input, even though the computation occurs only once.+--   It underlies the @rec@ value recursion construct in arrow notation.++class Arrow a => ArrowLoop a where+        loop :: a (b,d) (c,d) -> a b c++instance ArrowLoop (->) where+        loop f b = let (c,d) = f (b,d) in c++instance MonadFix m => ArrowLoop (Kleisli m) where+        loop (Kleisli f) = Kleisli (liftM fst . mfix . f')+                where   f' x y = f (x, snd y)
+ lib/applicative/Control/Category.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Category+-- Copyright   :  (c) Ashley Yakeley 2007+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  ashley@semantic.org+-- Stability   :  experimental+-- Portability :  portable++-- http://hackage.haskell.org/trac/ghc/ticket/1773++module Control.Category where++import Prelude hiding (id,(.))+import qualified Prelude++infixr 9 .+infixr 1 >>>, <<<++-- | A class for categories.+--   id and (.) must form a monoid.+class Category cat where+        -- | the identity morphism+        id :: cat a a++        -- | morphism composition+        (.) :: cat b c -> cat a b -> cat a c++{-# RULES+"identity/left" forall p .+                id . p = p+"identity/right"        forall p .+                p . id = p+"association"   forall p q r .+                (p . q) . r = p . (q . r)+ #-}++instance Category (->) where+        id = Prelude.id+        (.) = (Prelude..)++-- | Right-to-left composition+(<<<) :: Category cat => cat b c -> cat a b -> cat a c+(<<<) = (.)++-- | Left-to-right composition+(>>>) :: Category cat => cat a b -> cat b c -> cat a c+f >>> g = g . f
+ lib/applicative/Data/Foldable.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Foldable+-- Copyright   :  Ross Paterson 2005+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Class of data structures that can be folded to a summary value.+--+-- Many of these functions generalize "Prelude", "Control.Monad" and+-- "Data.List" functions of the same names from lists to any 'Foldable'+-- functor.  To avoid ambiguity, either import those modules hiding+-- these names or qualify uses of these function names with an alias+-- for this module.++module Data.Foldable (+        -- * Folds+        Foldable(..),+        -- ** Special biased folds+        foldr',+        foldl',+        foldrM,+        foldlM,+        -- ** Folding actions+        -- *** Applicative actions+        traverse_,+        for_,+        sequenceA_,+        asum,+        -- *** Monadic actions+        mapM_,+        forM_,+        sequence_,+        msum,+        -- ** Specialized folds+        toList,+        concat,+        concatMap,+        and,+        or,+        any,+        all,+        sum,+        product,+        maximum,+        maximumBy,+        minimum,+        minimumBy,+        -- ** Searches+        elem,+        notElem,+        find+        ) where++import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_,+                elem, notElem, concat, concatMap, and, or, any, all,+                sum, product, maximum, minimum)+import qualified Prelude (foldl, foldr, foldl1, foldr1)+import Control.Applicative+import Control.Monad (MonadPlus(..))+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Monoid++#ifdef __NHC__+import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build)+#endif++-- | Data structures that can be folded.+--+-- Minimal complete definition: 'foldMap' or 'foldr'.+--+-- For example, given a data type+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be+--+-- > instance Foldable Tree+-- >    foldMap f Empty = mempty+-- >    foldMap f (Leaf x) = f x+-- >    foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r+--+-- This is suitable even for abstract types, as the monoid is assumed+-- to satisfy the monoid laws.+--+class Foldable t where+        -- | Combine the elements of a structure using a monoid.+        fold :: Monoid m => t m -> m+        fold = foldMap id++        -- | Map each element of the structure to a monoid,+        -- and combine the results.+        foldMap :: Monoid m => (a -> m) -> t a -> m+        foldMap f = foldr (mappend . f) mempty++        -- | Right-associative fold of a structure.+        --+        -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@+        foldr :: (a -> b -> b) -> b -> t a -> b+        foldr f z t = appEndo (foldMap (Endo . f) t) z++        -- | Left-associative fold of a structure.+        --+        -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@+        foldl :: (a -> b -> a) -> a -> t b -> a+        foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z++        -- | A variant of 'foldr' that has no base case,+        -- and thus may only be applied to non-empty structures.+        --+        -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@+        foldr1 :: (a -> a -> a) -> t a -> a+        foldr1 f xs = fromMaybe (error "foldr1: empty structure")+                        (foldr mf Nothing xs)+          where mf x Nothing = Just x+                mf x (Just y) = Just (f x y)++        -- | A variant of 'foldl' that has no base case,+        -- and thus may only be applied to non-empty structures.+        --+        -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@+        foldl1 :: (a -> a -> a) -> t a -> a+        foldl1 f xs = fromMaybe (error "foldl1: empty structure")+                        (foldl mf Nothing xs)+          where mf Nothing y = Just y+                mf (Just x) y = Just (f x y)++-- instances for Prelude types++instance Foldable Maybe where+        foldr f z Nothing = z+        foldr f z (Just x) = f x z++        foldl f z Nothing = z+        foldl f z (Just x) = f z x++instance Foldable [] where+        foldr = Prelude.foldr+        foldl = Prelude.foldl+        foldr1 = Prelude.foldr1+        foldl1 = Prelude.foldl1++-- | Fold over the elements of a structure,+-- associating to the right, but strictly.+foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b+foldr' f z xs = foldl f' id xs z+  where f' k x z = k $! f x z++-- | Monadic fold over the elements of a structure,+-- associating to the right, i.e. from right to left.+foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b+foldrM f z xs = foldl f' return xs z+  where f' k x z = f x z >>= k++-- | Fold over the elements of a structure,+-- associating to the left, but strictly.+foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a+foldl' f z xs = foldr f' id xs z+  where f' x k z = k $! f z x++-- | Monadic fold over the elements of a structure,+-- associating to the left, i.e. from left to right.+foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a+foldlM f z xs = foldr f' return xs z+  where f' x k z = f z x >>= k++-- | Map each element of a structure to an action, evaluate+-- these actions from left to right, and ignore the results.+traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()+traverse_ f = foldr ((*>) . f) (pure ())++-- | 'for_' is 'traverse_' with its arguments flipped.+for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()+{-# INLINE for_ #-}+for_ = flip traverse_++-- | Map each element of a structure to a monadic action, evaluate+-- these actions from left to right, and ignore the results.+mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()+mapM_ f = foldr ((>>) . f) (return ())++-- | 'forM_' is 'mapM_' with its arguments flipped.+forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_ = flip mapM_++-- | Evaluate each action in the structure from left to right,+-- and ignore the results.+sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()+sequenceA_ = foldr (*>) (pure ())++-- | Evaluate each monadic action in the structure from left to right,+-- and ignore the results.+sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()+sequence_ = foldr (>>) (return ())++-- | The sum of a collection of actions, generalizing 'concat'.+asum :: (Foldable t, Alternative f) => t (f a) -> f a+{-# INLINE asum #-}+asum = foldr (<|>) empty++-- | The sum of a collection of actions, generalizing 'concat'.+msum :: (Foldable t, MonadPlus m) => t (m a) -> m a+{-# INLINE msum #-}+msum = foldr mplus mzero++-- These use foldr rather than foldMap to avoid repeated concatenation.++-- | List of elements of a structure.+toList :: Foldable t => t a -> [a]+#ifdef __GLASGOW_HASKELL__+toList t = build (\ c n -> foldr c n t)+#else+toList = foldr (:) []+#endif++-- | The concatenation of all the elements of a container of lists.+concat :: Foldable t => t [a] -> [a]+concat = fold++-- | Map a function over all the elements of a container and concatenate+-- the resulting lists.+concatMap :: Foldable t => (a -> [b]) -> t a -> [b]+concatMap = foldMap++-- | 'and' returns the conjunction of a container of Bools.  For the+-- result to be 'True', the container must be finite; 'False', however,+-- results from a 'False' value finitely far from the left end.+and :: Foldable t => t Bool -> Bool+and = getAll . foldMap All++-- | 'or' returns the disjunction of a container of Bools.  For the+-- result to be 'False', the container must be finite; 'True', however,+-- results from a 'True' value finitely far from the left end.+or :: Foldable t => t Bool -> Bool+or = getAny . foldMap Any++-- | Determines whether any element of the structure satisfies the predicate.+any :: Foldable t => (a -> Bool) -> t a -> Bool+any p = getAny . foldMap (Any . p)++-- | Determines whether all elements of the structure satisfy the predicate.+all :: Foldable t => (a -> Bool) -> t a -> Bool+all p = getAll . foldMap (All . p)++-- | The 'sum' function computes the sum of the numbers of a structure.+sum :: (Foldable t, Num a) => t a -> a+sum = getSum . foldMap Sum++-- | The 'product' function computes the product of the numbers of a structure.+product :: (Foldable t, Num a) => t a -> a+product = getProduct . foldMap Product++-- | The largest element of a non-empty structure.+maximum :: (Foldable t, Ord a) => t a -> a+maximum = foldr1 max++-- | The largest element of a non-empty structure with respect to the+-- given comparison function.+maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a+maximumBy cmp = foldr1 max'+  where max' x y = case cmp x y of+                        GT -> x+                        _  -> y++-- | The least element of a non-empty structure.+minimum :: (Foldable t, Ord a) => t a -> a+minimum = foldr1 min++-- | The least element of a non-empty structure with respect to the+-- given comparison function.+minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a+minimumBy cmp = foldr1 min'+  where min' x y = case cmp x y of+                        GT -> y+                        _  -> x++-- | Does the element occur in the structure?+elem :: (Foldable t, Eq a) => a -> t a -> Bool+elem = any . (==)++-- | 'notElem' is the negation of 'elem'.+notElem :: (Foldable t, Eq a) => a -> t a -> Bool+notElem x = not . elem x++-- | The 'find' function takes a predicate and a structure and returns+-- the leftmost element of the structure matching the predicate, or+-- 'Nothing' if there is no such element.+find :: Foldable t => (a -> Bool) -> t a -> Maybe a+find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])
+ lib/applicative/Data/Traversable.hs view
@@ -0,0 +1,182 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Traversable+-- Copyright   :  Conor McBride and Ross Paterson 2005+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Class of data structures that can be traversed from left to right,+-- performing an action on each element.+--+-- See also+--+--  * /Applicative Programming with Effects/,+--    by Conor McBride and Ross Paterson, online at+--    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+--  * /The Essence of the Iterator Pattern/,+--    by Jeremy Gibbons and Bruno Oliveira,+--    in /Mathematically-Structured Functional Programming/, 2006, and online at+--    <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.+--+-- Note that the functions 'mapM' and 'sequence' generalize "Prelude"+-- functions of the same names from lists to any 'Traversable' functor.+-- To avoid ambiguity, either import the "Prelude" hiding these names+-- or qualify uses of these function names with an alias for this module.++module Data.Traversable (+        Traversable(..),+        for,+        forM,+        mapAccumL,+        mapAccumR,+        fmapDefault,+        foldMapDefault,+        ) where++import Prelude hiding (mapM, sequence, foldr)+import qualified Prelude (mapM, foldr)+import Control.Applicative+import Data.Foldable (Foldable())+import Data.Monoid (Monoid)++-- | Functors representing data structures that can be traversed from+-- left to right.+--+-- Minimal complete definition: 'traverse' or 'sequenceA'.+--+-- Instances are similar to 'Functor', e.g. given a data type+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be+--+-- > instance Traversable Tree+-- >    traverse f Empty = pure Empty+-- >    traverse f (Leaf x) = Leaf <$> f x+-- >    traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r+--+-- This is suitable even for abstract types, as the laws for '<*>'+-- imply a form of associativity.+--+-- The superclass instances should satisfy the following:+--+--  * In the 'Functor' instance, 'fmap' should be equivalent to traversal+--    with the identity applicative functor ('fmapDefault').+--+--  * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be+--    equivalent to traversal with a constant applicative functor+--    ('foldMapDefault').+--+class (Functor t, Foldable t) => Traversable t where+        -- | Map each element of a structure to an action, evaluate+        -- these actions from left to right, and collect the results.+        traverse :: Applicative f => (a -> f b) -> t a -> f (t b)+        traverse f = sequenceA . fmap f++        -- | Evaluate each action in the structure from left to right,+        -- and collect the results.+        sequenceA :: Applicative f => t (f a) -> f (t a)+        sequenceA = traverse id++        -- | Map each element of a structure to a monadic action, evaluate+        -- these actions from left to right, and collect the results.+        mapM :: Monad m => (a -> m b) -> t a -> m (t b)+        mapM f = unwrapMonad . traverse (WrapMonad . f)++        -- | Evaluate each monadic action in the structure from left to right,+        -- and collect the results.+        sequence :: Monad m => t (m a) -> m (t a)+        sequence = mapM id++-- instances for Prelude types++instance Traversable Maybe where+        traverse f Nothing = pure Nothing+        traverse f (Just x) = Just <$> f x++instance Traversable [] where+        traverse f = Prelude.foldr cons_f (pure [])+          where cons_f x ys = (:) <$> f x <*> ys++        mapM = Prelude.mapM++--instance Ix i => Traversable (Array i) where+--        traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)++-- general functions++-- | 'for' is 'traverse' with its arguments flipped.+for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)+{-# INLINE for #-}+for = flip traverse++-- | 'forM' is 'mapM' with its arguments flipped.+forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)+{-# INLINE forM #-}+forM = flip mapM++-- left-to-right state transformer+newtype StateL s a = StateL { runStateL :: s -> (s, a) }++instance Functor (StateL s) where+        fmap f (StateL k) = StateL $ \ s ->+                let (s', v) = k s in (s', f v)++instance Applicative (StateL s) where+        pure x = StateL (\ s -> (s, x))+        StateL kf <*> StateL kv = StateL $ \ s ->+                let (s', f) = kf s+                    (s'', v) = kv s'+                in (s'', f v)++-- |The 'mapAccumL' function behaves like a combination of 'fmap'+-- and 'foldl'; it applies a function to each element of a structure,+-- passing an accumulating parameter from left to right, and returning+-- a final value of this accumulator together with the new structure.+mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s++-- right-to-left state transformer+newtype StateR s a = StateR { runStateR :: s -> (s, a) }++instance Functor (StateR s) where+        fmap f (StateR k) = StateR $ \ s ->+                let (s', v) = k s in (s', f v)++instance Applicative (StateR s) where+        pure x = StateR (\ s -> (s, x))+        StateR kf <*> StateR kv = StateR $ \ s ->+                let (s', v) = kv s+                    (s'', f) = kf s'+                in (s'', f v)++-- |The 'mapAccumR' function behaves like a combination of 'fmap'+-- and 'foldr'; it applies a function to each element of a structure,+-- passing an accumulating parameter from right to left, and returning+-- a final value of this accumulator together with the new structure.+mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s++-- | This function may be used as a value for `fmap` in a `Functor` instance.+fmapDefault :: Traversable t => (a -> b) -> t a -> t b+fmapDefault f = getId . traverse (Id . f)++-- | This function may be used as a value for `Data.Foldable.foldMap`+-- in a `Foldable` instance.+foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m+foldMapDefault f = getConst . traverse (Const . f)++-- local instances++newtype Id a = Id { getId :: a }++instance Functor Id where+        fmap f (Id x) = Id (f x)++instance Applicative Id where+        pure = Id+        Id f <*> Id x = Id (f x)
+ lib/applicative/applicative.yaml view
@@ -0,0 +1,10 @@+Name: applicative+Version: 1.0+Hs-Source-Dirs: .+Options: [ -phaskell2010, -phaskell-extras, --noauto ]+Exposed-Modules:+        - Control.Applicative+        - Control.Arrow+        - Control.Category+        - Data.Foldable+        - Data.Traversable
+ lib/ext/Diff.cabal view
@@ -0,0 +1,5 @@+name:                Diff+version:             0.2.0+synopsis:            O(ND) diff algorithm in haskell.+description:         Basic implementation of the standard diff algorithm.+exposed-modules:   Data.Algorithm.Diff
+ lib/ext/HUnit.cabal view
@@ -0,0 +1,16 @@+Name:                   HUnit+Version:                1.2.5.1+options:                -fcpp+Homepage:               http://hunit.sourceforge.net/+Category:               Testing+Synopsis:               A unit testing framework for Haskell+Description:+    HUnit is a unit testing framework for Haskell, inspired by the+    JUnit tool for Java, see: <http://www.junit.org>.++Build-Depends: deepseq+Exposed-Modules: Test.HUnit.Base,+        Test.HUnit.Lang,+        Test.HUnit.Terminal,+        Test.HUnit.Text,+        Test.HUnit
+ lib/ext/QuickCheck.cabal view
@@ -0,0 +1,27 @@+name:		QuickCheck+version:	1.2.0.1+license:	BSD3+license-file:	LICENSE+options:   -fcpp+author:		Koen Classen and John Hughes+maintainer:	libraries@haskell.org+category:	Testing+homepage:	http://www.math.chalmers.se/~rjmh/QuickCheck/+synopsis:	Automatic testing of Haskell programs+description:+	A library for testing Haskell programs automatically.+	The programmer provides a specification of the program, in+	the form of properties which functions should satisfy, and+	QuickCheck then tests that the properties hold in a large number+	of randomly generated cases.  Specifications are expressed in+	Haskell, using combinators defined in the QuickCheck library.+	QuickCheck provides combinators to define properties, observe+	the distribution of test data, and define test+	data generators.+++exposed-modules:+  Test.QuickCheck.Batch,+  Test.QuickCheck.Poly,+  Test.QuickCheck.Utils,+  Test.QuickCheck
+ lib/ext/bytestring.patch view
@@ -0,0 +1,22 @@+Only in bytestring-0.9.2.0.jhc: bytestring.yaml+diff -ru bytestring-0.9.2.0/Data/ByteString.hs bytestring-0.9.2.0.jhc/Data/ByteString.hs+--- bytestring-0.9.2.0/Data/ByteString.hs	2011-08-25 05:19:31.000000000 -0700++++ bytestring-0.9.2.0.jhc/Data/ByteString.hs	2012-02-06 04:48:48.116356373 -0800+@@ -243,7 +243,7 @@+ -- hGetBuf and hPutBuf not available in yhc or nhc+ import System.IO                (stdin,stdout,hClose,hFileSize+                                 ,hGetBuf,hPutBuf,openBinaryFile+-                                ,IOMode(..))++                                ,IOMode(..),Handle,hWaitForInput)+ import System.IO.Error          (mkIOError, illegalOperationErrorType)+ + import Data.Monoid              (Monoid, mempty, mappend, mconcat)+@@ -1910,7 +1910,7 @@+   bytesWritten <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l+   return $! drop bytesWritten bs+ #else+-hPutNonBlocking :: Handle -> B.ByteString -> IO Int++hPutNonBlocking :: Handle -> ByteString -> IO ByteString+ hPutNonBlocking h bs = hPut h bs >> return empty+ #endif+
+ lib/ext/bytestring.yaml view
@@ -0,0 +1,17 @@+Name:                bytestring+Version:             0.9.2.0+Synopsis:            Fast, packed, strict and lazy byte arrays with a list interface+Options: '-DMIN_VERSION_base(x,y,z)=0'+exposed-modules:+       - Data.ByteString+       - Data.ByteString.Char8+       - Data.ByteString.Unsafe+       - Data.ByteString.Internal+       - Data.ByteString.Lazy+       - Data.ByteString.Lazy.Char8+       - Data.ByteString.Lazy.Internal+       - Data.ByteString.Fusion+extensions:        [ CPP, ForeignFunctionInterface, NamedFieldPuns ]+hs-source-dir:     .+c-sources:         cbits/fpstring.c+include-sources:   include/fpstring.h
+ lib/ext/containers.cabal view
@@ -0,0 +1,27 @@+name:       containers+version:    0.3.0.0+options:    -fcpp -Isrc/data -papplicative+license:    BSD3+license-file:    LICENSE+maintainer:    libraries@haskell.org+bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29+synopsis:   Assorted concrete container types+category:   Data Structures+description:+        This package contains efficient general-purpose implementations+        of various basic immutable container types.  The declared cost of+        each operation is either worst-case or amortized, but remains+        valid even if structures are shared.+build-type: Simple+extra-source-files: include/Typeable.h+extensions: CPP++exposed-modules:+        Data.Graph+        Data.IntMap+        Data.IntSet+        Data.Map+        Data.Sequence+        Data.Set+        Data.Tree+
+ lib/ext/containers.patch view
@@ -0,0 +1,22 @@+Only in containers-0.3.0.0: containers.patch+diff -ru containers-0.3.0.0/Data/Sequence.hs containers-0.3.0.0-new/Data/Sequence.hs+--- containers-0.3.0.0/Data/Sequence.hs	2009-11-19 07:51:36.000000000 -0800++++ containers-0.3.0.0-new/Data/Sequence.hs	2010-07-21 13:42:30.000000000 -0700+@@ -1501,7 +1501,7 @@+ 				foldrWithIndex g n xs)+ #else+ findIndicesL p xs = foldrWithIndex g [] xs where+-g i x is = if p x then i:is else is++    g i x is = if p x then i:is else is+ #endif++ {-# INLINE findIndicesR #-}+@@ -1513,7 +1513,7 @@+ 				foldlWithIndex g n xs)+ #else+ findIndicesR p xs = foldlWithIndex g [] xs where+-g is i x = if p x then i:is else is++    g is i x = if p x then i:is else is+ #endif++ ------------------------------------------------------------------------
+ lib/ext/deepseq.cabal view
@@ -0,0 +1,24 @@+name:		deepseq+version:	1.2.0.1+license:	BSD3+license-file:	LICENSE+maintainer:	libraries@haskell.org+synopsis:	Deep evaluation of data structures+category:       Control+options:  -pcontainers -fcpp+description:+    This package provides methods for fully evaluating data structures+    (\"deep evaluation\"). Deep evaluation is often used for adding+    strictness to a program, e.g. in order to force pending exceptions,+    remove space leaks, or force lazy I/O to happen. It is also useful+    in parallel programs, to ensure pending work does not migrate to the+    wrong thread.+    .+    The primary use of this package is via the 'deepseq' function, a+    \"deep\" version of 'seq'. It is implemented on top of an 'NFData'+    typeclass (\"Normal Form Data\", data structures with no unevaluated+    components) which defines strategies for fully evaluating different+    data types.+    .+build-depends: containers+exposed-modules: Control.DeepSeq
+ lib/ext/filepath.cabal view
@@ -0,0 +1,17 @@+Name:           filepath+Version:        1.3.0.1+License:        BSD3+license-file:   LICENSE+Author:         Neil Mitchell+bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29+Homepage:       http://www-users.cs.york.ac.uk/~ndm/filepath/+Category:       System+build-type:     Simple+Synopsis:       Library for manipulating FilePaths in a cross platform way.+cabal-version:  >=1.6+Extra-Source-Files: System/FilePath/Internal.hs++Exposed-modules:+        System.FilePath+        System.FilePath.Posix+        System.FilePath.Windows
+ lib/ext/html.cabal view
@@ -0,0 +1,15 @@+name:		html+version:	1.0.1.2+license:	BSD3+license-file:	LICENSE+maintainer:	libraries@haskell.org+synopsis:	HTML combinator library+category:       Web+description:+	This package contains a combinator library for constructing+        HTML documents.+build-type:     Simple+exposed-modules:+	Text.Html+	Text.Html.BlockTable+nhc98-options: -K2M
+ lib/ext/parsec.cabal view
@@ -0,0 +1,32 @@+name:		parsec+version:	2.1.0.1+license:	BSD3+license-file:	LICENSE+author:		Daan Leijen <daan@cs.uu.nl>+maintainer:	Daan Leijen <daan@cs.uu.nl>+homepage:	http://www.cs.uu.nl/~daan/parsec.html+category:	Parsing+synopsis:	Monadic parser combinators+description:+    Parsec is designed from scratch as an industrial-strength parser+    library.  It is simple, safe, well documented (on the package+    homepage), has extensive libraries and good error messages,+    and is also fast.+exposed-modules:+    Text.ParserCombinators.Parsec.Error,+    Text.ParserCombinators.Parsec.Char,+    Text.ParserCombinators.Parsec.Combinator,+    Text.ParserCombinators.Parsec.Expr,+--    Text.ParserCombinators.Parsec.Perm,+    Text.ParserCombinators.Parsec.Pos,+    Text.ParserCombinators.Parsec.Prim,+    Text.ParserCombinators.Parsec+--  build-depends:	base+--  extensions:	ExistentialQuantification+--  if !impl(nhc98) {+--    extensions:	PolymorphicComponents+--    exposed-modules:+--      Text.ParserCombinators.Parsec.Language,+--      Text.ParserCombinators.Parsec.Token+--  }+--}
+ lib/ext/pretty.cabal view
@@ -0,0 +1,11 @@+name:		pretty+version:	1.0.1.2+synopsis:	Pretty-printing library+category:       Text+options:        -fcpp+description:+	This package contains John Hughes's pretty-printing library,+        heavily modified by Simon Peyton Jones.+Exposed-Modules:+        Text.PrettyPrint+        Text.PrettyPrint.HughesPJ
+ lib/ext/safe.cabal view
@@ -0,0 +1,22 @@+Name:           safe+Build-Type:     Simple+Version:        0.3.3+License:        BSD3+License-File:   LICENSE+Copyright:      2007-8, Neil Mitchell+Maintainer:     ndmitchell@gmail.com+Author:         Neil Mitchell+Homepage:       http://www-users.cs.york.ac.uk/~ndm/safe/+Build-Depends:  haskell-extras, applicative+Category:       Unclassified+Synopsis:       Library for safe (pattern match free) functions+Description:+    Partial functions from the base library, such as @head@ and @!!@, modified+    to return more descriptive error messages, programmer defined error messages,+    @Maybe@ wrapped results and default values.++    These functions can be used to reduce the number of unsafe pattern matches in+    your code.+Exposed-modules:+        Safe+        Safe.Foldable
+ lib/ext/smallcheck.cabal view
@@ -0,0 +1,11 @@+Name:          smallcheck+Version:       0.6.1+Author:        Colin Runciman+Synopsis:      Another lightweight testing library in Haskell.+Description:   SmallCheck is similar to QuickCheck (Claessen and Hughes 2000-) but+               instead of testing for a sample of randomly generated values, SmallCheck+               tests properties for all the finitely many values up to some depth,+               progressively increasing the depth used.++Build-Depends: haskell98, haskell-extras+Exposed-modules:    Test.SmallCheck
+ lib/ext/transformers.cabal view
@@ -0,0 +1,38 @@+name:         transformers+version:      0.2.1.0+options:     -papplicative+synopsis:     Concrete functor and monad transformers+description:+    Haskell 98 part of a monad transformer library, inspired by the paper+    \"Functional Programming with Overloading and Higher-Order Polymorphism\",+    by Mark P Jones, in /Advanced School of Functional Programming/, 1995+    (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>).+    .+    This part contains the monad transformer class, the concrete monad+    transformers, operations and liftings.  It can be used on its own+    in Haskell 98 code, or with the monad classes in the @monads-fd@ or+    @monads-tf@ packages, which automatically lift operations introduced+    by monad transformers through other transformers.++exposed-modules:+    Control.Monad.IO.Class+    Control.Monad.Trans.Class+    Control.Monad.Trans.Cont+    Control.Monad.Trans.Error+    Control.Monad.Trans.Identity+    Control.Monad.Trans.List+    Control.Monad.Trans.Maybe+    Control.Monad.Trans.Reader+    Control.Monad.Trans.RWS+    Control.Monad.Trans.RWS.Lazy+    Control.Monad.Trans.RWS.Strict+    Control.Monad.Trans.State+    Control.Monad.Trans.State.Lazy+    Control.Monad.Trans.State.Strict+    Control.Monad.Trans.Writer+    Control.Monad.Trans.Writer.Lazy+    Control.Monad.Trans.Writer.Strict+    Data.Functor.Compose+    Data.Functor.Constant+    Data.Functor.Identity+    Data.Functor.Product
+ lib/ext/utility-ht.cabal view
@@ -0,0 +1,41 @@+Name:             utility-ht+Version:          0.0.5.1+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+Category:         Data, List+Synopsis:         Various small helper functions for Lists, Maybes, Tuples, Functions+Description:+  Various small helper functions for Lists, Maybes, Tuples, Functions.+  Some of these functions are improved implementations of standard functions.+  They have the same name as their standard counterparts.++  The package only contains functions+  that do not require packages other than the base package.+  Thus you do not risk a dependency avalanche by importing it.+  However, further splitting the base package might invalidate this statement.++Exposed-Modules:+    Data.Bool.HT+    Data.Eq.HT+    Data.Function.HT+    Data.List.HT+    Data.List.Key+    Data.List.Match+    Data.Maybe.HT+    Data.Ord.HT+    Data.Record.HT+    Data.String.HT+    Data.Tuple.HT+    Control.Monad.HT+    Data.Strictness.HT+    Text.Read.HT+    Text.Show.HT++Hidden-Modules:+    Data.Bool.HT.Private+    Data.List.HT.Private+    Data.List.Key.Private+    Data.List.Match.Private+    Data.Function.HT.Private+    Data.Record.HT.Private+
+ lib/ext/xhtml.cabal view
@@ -0,0 +1,33 @@+Name: xhtml+Version: 3000.2.1+Copyright: Bjorn Bringert 2004-2006, Andy Gill, and the Oregon Graduate+           Institute of Science and Technology, 1999-2001+Maintainer: bjorn@bringert.net+Author: Bjorn Bringert+License: BSD3+License-file: LICENSE+Options: -fcpp+Extensions: CPP+Synopsis: An XHTML combinator library+Description:+ This package provides combinators for producing+  XHTML 1.0, including the Strict, Transitional and Frameset variants.+Build-Type: Simple+Exposed-Modules:+  Text.XHtml,+  Text.XHtml.Frameset,+  Text.XHtml.Strict,+  Text.XHtml.Transitional,+  Text.XHtml.Debug,+  Text.XHtml.Table+Hidden-modules:+  Text.XHtml.Strict.Attributes,+  Text.XHtml.Strict.Elements,+  Text.XHtml.Frameset.Attributes,+  Text.XHtml.Frameset.Elements,+  Text.XHtml.Transitional.Attributes,+  Text.XHtml.Transitional.Elements,+  Text.XHtml.BlockTable,+  Text.XHtml.Extras,+  Text.XHtml.Internals+ghc-options: -O2 -W
+ lib/flat-foreign/Bits.hs view
@@ -0,0 +1,3 @@+module Bits (module Data.Bits) where+import Data.Bits+
+ lib/flat-foreign/CError.hs view
@@ -0,0 +1,2 @@+module CError (module Foreign.C.Error) where+import Foreign.C.Error
+ lib/flat-foreign/CForeign.hs view
@@ -0,0 +1,2 @@+module CForeign ( module Foreign.C ) where+import Foreign.C
+ lib/flat-foreign/CString.hs view
@@ -0,0 +1,2 @@+module CString (module Foreign.C.String) where+import Foreign.C.String
+ lib/flat-foreign/CTypes.hs view
@@ -0,0 +1,2 @@+module CTypes (module Foreign.C.Types) where+import Foreign.C.Types
+ lib/flat-foreign/ForeignPtr.hs view
@@ -0,0 +1,2 @@+module ForeignPtr (module Foreign.ForeignPtr) where+import Foreign.ForeignPtr
+ lib/flat-foreign/Int.hs view
@@ -0,0 +1,2 @@+module Int ( module Data.Int ) where+import Data.Int
+ lib/flat-foreign/MarshalAlloc.hs view
@@ -0,0 +1,2 @@+module MarshalAlloc (module Foreign.Marshal.Alloc) where+import Foreign.Marshal.Alloc
+ lib/flat-foreign/MarshalArray.hs view
@@ -0,0 +1,2 @@+module MarshalArray (module Foreign.Marshal.Array) where+import Foreign.Marshal.Array
+ lib/flat-foreign/MarshalError.hs view
@@ -0,0 +1,17 @@+module MarshalError (+  	module Foreign.Marshal.Error,+--	IOErrorType,+--	mkIOError,+--	alreadyExistsErrorType,+--	doesNotExistErrorType,+--	alreadyInUseErrorType,+--	fullErrorType,+--	eofErrorType,+--	illegalOperationErrorType,+--	permissionErrorType,+--	userErrorType,+--	annotateIOError+  ) where++import System.IO.Error+import Foreign.Marshal.Error
+ lib/flat-foreign/MarshalUtils.hs view
@@ -0,0 +1,2 @@+module MarshalUtils (module Foreign.Marshal.Utils) where+import Foreign.Marshal.Utils
+ lib/flat-foreign/Ptr.hs view
@@ -0,0 +1,2 @@+module Ptr (module Foreign.Ptr) where+import Foreign.Ptr
+ lib/flat-foreign/StablePtr.hs view
@@ -0,0 +1,2 @@+module StablePtr (module Foreign.StablePtr) where+import Foreign.StablePtr
+ lib/flat-foreign/Storable.hs view
@@ -0,0 +1,2 @@+module Storable (module Foreign.Storable) where+import Foreign.Storable
+ lib/flat-foreign/Word.hs view
@@ -0,0 +1,2 @@+module Word ( module Data.Word ) where+import Data.Word
+ lib/flat-foreign/flat-foreign.yaml view
@@ -0,0 +1,8 @@+Name: flat-foreign+Version: 1.0+hs-source-dir: .+build-depends: [haskell2010]+options: --noauto+exposed-modules: [ Bits, CError, CForeign, CString, CTypes, ForeignPtr, Int,+        MarshalAlloc, MarshalArray, MarshalError, MarshalUtils, Ptr,+        StablePtr, Storable, Word ]
+ lib/haskell-extras/Control/Exception.hs view
@@ -0,0 +1,64 @@+-- | This is mostly dummy, JHC does not support inexact exceptions.++module Control.Exception where++import Prelude hiding(catch)+import qualified Prelude as P++type IOException = IOError++data Exception = IOException IOException++-- throw :: Exception -> a++assert :: Bool -> a -> a+assert True x = x+assert False _ = error "assertion failure"++throwIO :: Exception -> IO a+throwIO (IOException ioe) = ioError ioe++catch :: IO a -> (Exception -> IO a) -> IO a+catch c h = P.catch c (h . IOException)++catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a+catchJust et c h = catch c $ \e -> maybe (throwIO e) h (et e)++handle :: (Exception -> IO a) -> IO a -> IO a+handle = flip catch++handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a+handleJust et h c = catchJust et c h++try :: IO a -> IO (Either Exception a)+try c = catch (fmap Right c) (return . Left)++tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)+tryJust et c = catchJust et (fmap Right c) (return . Left)++-- FIXME this is wrong!+evaluate :: a -> IO a+evaluate = return++-- mapException++ioErrors (IOException _) = True++block, unblock :: IO a -> IO a+block   = id+unblock = id++bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+bracket before after m = do+        x  <- before+        rs <- try (m x)+        after x+        case rs of+           Right r -> return r+           Left  e -> throwIO e++bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c+bracket_ before after m = bracket before after (const m)++finally :: IO a -> IO b -> IO a+finally cmd end = bracket_ (return ()) (const end) cmd
+ lib/haskell-extras/Control/Monad.hs view
@@ -0,0 +1,125 @@+module Control.Monad (+    Functor(fmap),  Monad((>>=), (>>), return, fail),  MonadPlus(mzero, mplus),+    mapM,  mapM_,  forM,  forM_,  sequence,  sequence_,  (=<<),  (>=>),  (<=<),+    forever,  void,  join,  msum,  filterM,  mapAndUnzipM,  zipWithM,+    zipWithM_,  foldM,  foldM_,  replicateM,  replicateM_,  guard,  when,+    unless,  liftM,  liftM2,  liftM3,  liftM4,  liftM5,  ap+    ) where++class Monad m => MonadPlus m where+    mzero :: m a+    mplus :: m a -> m a -> m a+    mzero = fail "mzero"++instance MonadPlus Maybe where+    mzero = Nothing+    Nothing `mplus` y = y+    x `mplus` _ = x++instance MonadPlus [] where+    mzero = []+    mplus = (++)++-- Functions++msum  :: MonadPlus m => [m a] -> m a+msum xs  =  foldr mplus mzero xs++join             :: (Monad m) => m (m a) -> m a+join x           =  x >>= id++when             :: (Monad m) => Bool -> m () -> m ()+when p s         =  if p then s else return ()++unless           :: (Monad m) => Bool -> m () -> m ()+unless p s       =  when (not p) s++ap               :: (Monad m) => m (a -> b) -> m a -> m b+ap               =  liftM2 ($)++guard            :: MonadPlus m => Bool -> m ()+guard p          =  if p then return () else mzero++mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip++zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys =  sequence (zipWith f xs ys)++zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++foldM            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM f a []     =  return a+foldM f a (x:xs) =  f a x >>= \ y -> foldM f y xs++filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]+filterM p []     = return []+filterM p (x:xs) = do { b  <- p x;+ys <- filterM p xs;+return (if b then (x:ys) else ys)+   }++liftM            :: (Monad m) => (a -> b) -> (m a -> m b)+liftM f          =  \a -> do { a' <- a; return (f a') }++liftM2           :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)+liftM2 f         =  \a b -> do { a' <- a; b' <- b; return (f a' b') }++liftM3           :: (Monad m) => (a -> b -> c -> d) ->+                                 (m a -> m b -> m c -> m d)+liftM3 f         =  \a b c -> do { a' <- a; b' <- b; c' <- c;+   return (f a' b' c') }++liftM4           :: (Monad m) => (a -> b -> c -> d -> e) ->+                                 (m a -> m b -> m c -> m d -> m e)+liftM4 f         =  \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;+     return (f a' b' c' d') }++liftM5           :: (Monad m) => (a -> b -> c -> d -> e -> f) ->+                                 (m a -> m b -> m c -> m d -> m e -> m f)+liftM5 f         =  \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;+       e' <- e; return (f a' b' c' d' e') }++-- extensions++-- | Like 'foldM', but discards the result.+foldM_            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()+foldM_ f a xs     = foldM f a xs >> return ()++-- | @'replicateM' n act@ performs the action @n@ times,+-- gathering the results.+replicateM        :: (Monad m) => Int -> m a -> m [a]+replicateM n x    = sequence (replicate n x)++-- | Like 'replicateM', but discards the result.+replicateM_       :: (Monad m) => Int -> m a -> m ()+replicateM_ n x   = sequence_ (replicate n x)++-- | 'forM' is 'mapM' with its arguments flipped+forM            :: Monad m => [a] -> (a -> m b) -> m [b]+{-# INLINE forM #-}+forM            = flip mapM++-- | 'forM_' is 'mapM_' with its arguments flipped+forM_           :: Monad m => [a] -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_           = flip mapM_++infixr 1 <=<, >=>++-- | Left-to-right Kleisli composition of monads.+(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+f >=> g     = \x -> f x >>= g++-- | Right-to-left Kleisli composition of monads. '(>=>)', with the+-- arguments flipped+(<=<)       :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)+(<=<)       = flip (>=>)++-- | @'forever' act@ repeats the action infinitely.+forever     :: (Monad m) => m a -> m ()+forever a   = a >> forever a++void :: Monad m => m a -> m ()+void x = x >> return ()
+ lib/haskell-extras/Control/Monad/Fix.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Fix+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Monadic fixpoints.+--+-- For a detailed discussion, see Levent Erkok's thesis,+-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.+--+-----------------------------------------------------------------------------++module Control.Monad.Fix (+        MonadFix(+           mfix -- :: (a -> m a) -> m a+         ),+        fix     -- :: (a -> a) -> a+  ) where++import Control.Monad.Instances ()+import Data.Function (fix)+import Jhc.IO++-- | Monads having fixed points with a \'knot-tying\' semantics.+-- Instances of 'MonadFix' should satisfy the following laws:+--+-- [/purity/]+--      @'mfix' ('return' . h)  =  'return' ('fix' h)@+--+-- [/left shrinking/ (or /tightening/)]+--      @'mfix' (\\x -> a >>= \\y -> f x y)  =  a >>= \\y -> 'mfix' (\\x -> f x y)@+--+-- [/sliding/]+--      @'mfix' ('Control.Monad.liftM' h . f)  =  'Control.Monad.liftM' h ('mfix' (f . h))@,+--      for strict @h@.+--+-- [/nesting/]+--      @'mfix' (\\x -> 'mfix' (\\y -> f x y))  =  'mfix' (\\x -> f x x)@+--+-- This class is used in the translation of the recursive @do@ notation+-- supported by GHC and Hugs.+class (Monad m) => MonadFix m where+        -- | The fixed point of a monadic computation.+        -- @'mfix' f@ executes the action @f@ only once, with the eventual+        -- output fed back as the input.  Hence @f@ should not be strict,+        -- for then @'mfix' f@ would diverge.+        mfix :: (a -> m a) -> m a++-- Instances of MonadFix for Prelude monads++-- Maybe:+instance MonadFix Maybe where+    mfix f = let a = f (unJust a) in a+             where unJust (Just x) = x++-- List:+instance MonadFix [] where+    mfix f = case fix (f . head) of+               []    -> []+               (x:_) -> x : mfix (tail . f)++-- IO:+instance MonadFix IO where+    mfix = fixIO++instance MonadFix ((->) r) where+    mfix f = \ r -> let a = f a r in a
+ lib/haskell-extras/Control/Monad/Instances.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Instances+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- 'Functor' and 'Monad' instances for @(->) r@ and+-- 'Functor' instances for @(,) a@ and @'Either' a@.++module Control.Monad.Instances (Functor(..),Monad(..)) where++instance Functor ((->) r) where+        fmap = (.)++instance Monad ((->) r) where+        return = const+        f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+        fmap f (x,y) = (x, f y)++instance Functor (Either a) where+        fmap _ (Left x) = Left x+        fmap f (Right y) = Right (f y)
+ lib/haskell-extras/Data/Array.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_JHC -funboxed-tuples #-}+module Data.Array (+    module Data.Ix,  -- export all of Ix+    Array(),+    array,+    listArray,+    accumArray,+    (!),+    bounds,+    indices,+    elems,+    assocs,+    (//),+    accum,+    ixmap+    ) where++import Data.Ix+import Jhc.Int+import Jhc.Prim.Array+import Jhc.Prim.IO++infixl 9  !, //++data Array a b = MkArray !a !a (Array_ b)++array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b+array b@(s,e) ivs = case newArray (error "array: missing element") (rangeSize b) [(index b x,y) | (x,y) <- ivs] of+        arr -> MkArray s e arr++listArray             :: (Ix a) => (a,a) -> [b] -> Array a b+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)++(!)                   :: (Ix a) => Array a b -> a -> b+(!) (MkArray s e arr) i =  case unboxInt (index (s,e) i) of i' -> case indexArray__ arr i' of (# r #) -> r++bounds                :: (Ix a) => Array a b -> (a,a)+bounds (MkArray s e _)  =  (s,e)++indices               :: (Ix a) => Array a b -> [a]+indices               =  range . bounds++elems                 :: (Ix a) => Array a b -> [b]+elems a               =  [a!i | i <- indices a]++assocs                :: (Ix a) => Array a b -> [(a,b)]+assocs a              =  [(i, a!i) | i <- indices a]++(//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b+a // []               = a+a // new_ivs          = array (bounds a) (old_ivs ++ new_ivs)+                      where+                  	old_ivs = [(i,a!i) | i <- indices a,+                                             i `notElem` new_is]+                  	new_is  = [i | (i,_) <- new_ivs]++accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])++accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])++ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c+ixmap b f a           = array b [(i, a ! f i) | i <- range b]++instance  (Ix a)          => Functor (Array a) where+    fmap fn a = array (bounds a) [ (a,fn b) | (a,b) <- assocs a ]++instance  (Ix a, Eq b)  => Eq (Array a b)  where+    a == a' =  assocs a == assocs a'++instance  (Ix a, Ord b) => Ord (Array a b)  where+    a <= a' =  assocs a <= assocs a'++instance  (Ix a, Show a, Show b) => Show (Array a b)  where+    showsPrec p a = showParen (p > arrPrec) (+                    showString "array " .+                    showsPrec (arrPrec+1) (bounds a) . showChar ' ' .+                    showsPrec (arrPrec+1) (assocs a)                  )+instance  (Ix a, Read a, Read b) => Read (Array a b)  where+    readsPrec p = readParen (p > arrPrec)+           (\r -> [ (array b as, u)+                  | ("array",s) <- lex r,+                    (b,t)       <- readsPrec (arrPrec+1) s,+                    (as,u)      <- readsPrec (arrPrec+1) t ])++-- Precedence of the 'array' function is that of application itself+arrPrec :: Int+arrPrec = 10++foreign import primitive newWorld__ :: a -> World__++newArray :: a -> Int -> [(Int,a)] -> Array_ a+newArray init n xs = case unboxInt n of+    n' -> case newWorld__ (init,n,xs) of+     w -> case newArray__ n' init w of+      (# w, arr #) -> let+        f :: MutArray_ a -> World__ -> [(Int,a)] -> World__+        f arr w [] = w+        f arr w ((i,v):xs) = case unboxInt i of i' -> case writeArray__ arr i' v w of w -> f arr w xs+            in case f arr w xs of w -> Array_ arr `worldDep_` w++foreign import primitive "dependingOn" worldDep_ :: Array_ b -> World__ -> Array_ b
+ lib/haskell-extras/Data/Array/IO.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS_JHC -fno-prelude -funboxed-tuples -fffi #-}+module Data.Array.IO where++import Jhc.Prim.Array+import Data.Ix+import Jhc.IO+import Jhc.Int++data IOArray a b = IOA !a !a (MutArray_ b)++newIOArray :: Ix a => (a,a) -> b -> IO (IOArray a b)+newIOArray rng fill = fromUIO (newIOArray_ rng fill)++newIOArray_ :: Ix a => (a,a) -> b -> World__ -> (# World__, IOArray a b #)+newIOArray_ rng@(l,h) fill w1 =+    case unboxInt (rangeSize rng) of+      size__ -> case newArray__ size__ fill w1 of+                  (# w2, arr #) -> (# w2, IOA l h arr #)++boundsIOArray :: Ix a => IOArray a b -> IO (a,a)+boundsIOArray (IOA l h _) = returnIO (l,h)++readIOArray :: Ix a => IOArray a b -> a -> IO b+readIOArray (IOA l h arr) i =+    case unboxInt (index (l,h) i) of+      i' -> fromUIO (readArray__ arr i')++writeIOArray :: Ix a => IOArray a b -> a -> b -> IO ()+writeIOArray (IOA l h arr) i x =+    case unboxInt (index (l,h) i) of+      i' -> fromUIO (\w1 -> case writeArray__ arr i' x w1 of+                         w2 -> (# w2, () #))++unsafeReadIOArray :: Ix a => IOArray a b -> Int -> IO b+unsafeReadIOArray (IOA l h arr) i = case unboxInt i of i' -> fromUIO (readArray__ arr i')++unsafeWriteIOArray :: Ix a => IOArray a b -> Int -> b -> IO ()+unsafeWriteIOArray (IOA l h arr) i x =+    case unboxInt i of i' -> fromUIO (\w1 -> case writeArray__ arr i' x w1 of+                                          w2 -> (# w2, () #))++{-+freezeIOArray :: Ix a => IOArray a b -> IO (Array a b)+thawIOArray :: Ix a => Array a b -> IO (IOArray a b)++unsafeFreezeIOArray :: Ix a => IOArray a b -> IO (Array a b)+unsafeFreezeIOArray (IOA l h arr) =+    IO (\w1 -> unsafeFreezeArray__ )+-}
+ lib/haskell-extras/Data/Array/Unboxed.hs view
@@ -0,0 +1,81 @@+module Data.Array.Unboxed where++import Data.Ix+import System.IO.Unsafe+import Foreign.Storable+import Foreign.ForeignPtr++infixl 9  !, //++data UArray i e = MkArray !i !i (ForeignPtr e)++array       :: (Ix a,Storable b) => (a,a) -> [(a,b)] -> UArray a b+array b@(s,e) ivs = MkArray s e (unsafePerformIO arr) where+    arr = do+        let f :: [(a,b)] -> b; f _ = undefined+        fp <- mallocForeignPtrBytes (sizeOf (f ivs) *  rangeSize b)+        withForeignPtr fp $ \ptr ->+            mapM_ (\ (i,v) -> pokeElemOff ptr (index b i) v) ivs+        return fp+++listArray             :: (Ix a,Storable b) => (a,a) -> [b] -> UArray a b+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)++(!)                   :: (Ix a,Storable b) => UArray a b -> a -> b+(!) (MkArray s e arr) i = case (index (s,e) i) of i' -> unsafePerformIO (withForeignPtr arr (\ptr -> peekElemOff ptr i'))++bounds                :: (Ix a) => UArray a b -> (a,a)+bounds (MkArray s e _)  =  (s,e)++indices               :: (Ix a) => UArray a b -> [a]+indices               =  range . bounds++elems                 :: (Ix a,Storable b) => UArray a b -> [b]+elems a               =  [a!i | i <- indices a]++assocs                :: (Ix a,Storable b) => UArray a b -> [(a,b)]+assocs a              =  [(i, a!i) | i <- indices a]++(//)                  :: (Ix a,Storable b) => UArray a b -> [(a,b)] -> UArray a b+a // []               = a+a // new_ivs          = array (bounds a) (old_ivs ++ new_ivs)+                      where+                  	old_ivs = [(i,a!i) | i <- indices a,+                                             i `notElem` new_is]+                  	new_is  = [i | (i,_) <- new_ivs]++accum                 :: (Ix a,Storable b ) => (b -> c -> b) -> UArray a b -> [(a,c)] -> UArray a b+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])++accumArray            :: (Ix a,Storable b ) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> UArray a b+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])++ixmap                 :: (Ix a, Ix b,Storable c) => (a,a) -> (a -> b) -> UArray b c -> UArray a c+ixmap b f a           = array b [(i, a ! f i) | i <- range b]++--instance  (Ix a)          => Functor (UArray a) where+--    fmap fn a = array (bounds a) [ (a,fn b) | (a,b) <- assocs a ]++instance  (Ix a, Eq b, Storable b)  => Eq (UArray a b)  where+    a == a' =  assocs a == assocs a'++instance  (Ix a, Ord b, Storable b) => Ord (UArray a b)  where+    a <= a' =  assocs a <= assocs a'++instance  (Ix a, Show a, Show b, Storable b) => Show (UArray a b)  where+    showsPrec p a = showParen (p > arrPrec) (+                    showString "array " .+                    showsPrec (arrPrec+1) (bounds a) . showChar ' ' .+                    showsPrec (arrPrec+1) (assocs a)                  )+instance  (Ix a, Read a, Read b, Storable b) => Read (UArray a b)  where+    readsPrec p = readParen (p > arrPrec)+           (\r -> [ (array b as, u)+                  | ("array",s) <- lex r,+                    (b,t)       <- readsPrec (arrPrec+1) s,+                    (as,u)      <- readsPrec (arrPrec+1) t ])++-- Precedence of the 'array' function is that of application itself+arrPrec :: Int+arrPrec = 10+
+ lib/haskell-extras/Data/Bits.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS_JHC -fm4 -fno-prelude -fffi  #-}+module Data.Bits where+++import Jhc.Num+import Jhc.Order+import Jhc.Basics++m4_include(Data/Bits.m4)+++infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`+infixl 7 .&.+infixl 6 `xor`+infixl 5 .|.+++{-|+The 'Bits' class defines bitwise operations over integral types.++* Bits are numbered from 0 with bit 0 being the least+  significant bit.+-}+class Num a => Bits a where+    -- | Bitwise \"and\"+    (.&.) :: a -> a -> a++    -- | Bitwise \"or\"+    (.|.) :: a -> a -> a++    -- | Bitwise \"xor\"+    xor :: a -> a -> a++    {-| Reverse all the bits in the argument -}+    complement        :: a -> a++    {-| Shift the argument left by the specified number of bits.+	Right shifts (signed) are specified by giving a negative value.++	An instance can define either this unified 'shift' or 'shiftL' and+	'shiftR', depending on which is more convenient for the type in+	question. -}+    shift             :: a -> Int -> a++    x `shift`   i | i<0  = x `shiftR` (-i)+                  | i==0 = x+                  | i>0  = x `shiftL` i++    {-| Rotate the argument left by the specified number of bits.+	Right rotates are specified by giving a negative value.++        For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.++	An instance can define either this unified 'rotate' or 'rotateL' and+	'rotateR', depending on which is more convenient for the type in+	question. -}+    rotate            :: a -> Int -> a++    x `rotate`  i | i<0  = x `rotateR` (-i)+                  | i==0 = x+                  | i>0  = x `rotateL` i++    {-+    -- Rotation can be implemented in terms of two shifts, but care is+    -- needed for negative values.  This suggested implementation assumes+    -- 2's-complement arithmetic.  It is commented out because it would+    -- require an extra context (Ord a) on the signature of 'rotate'.+    x `rotate`  i | i<0 && isSigned x && x<0+                         = let left = i+bitSize x in+                           ((x `shift` i) .&. complement ((-1) `shift` left))+                           .|. (x `shift` left)+                  | i<0  = (x `shift` i) .|. (x `shift` (i+bitSize x))+                  | i==0 = x+                  | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))+    -}++    -- | @bit i@ is a value with the @i@th bit set+    bit               :: Int -> a++    -- | @x \`setBit\` i@ is the same as @x .|. bit i@+    setBit            :: a -> Int -> a++    -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@+    clearBit          :: a -> Int -> a++    -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@+    complementBit     :: a -> Int -> a++    -- | Return 'True' if the @n@th bit of the argument is 1+    testBit           :: a -> Int -> Bool++    {-| Return the number of bits in the type of the argument.  The actual+	value of the argument is ignored.  The function 'bitSize' is+	undefined for types that do not have a fixed bitsize, like 'Integer'.+	-}+    bitSize           :: a -> Int++    {-| Return 'True' if the argument is a signed type.  The actual+        value of the argument is ignored -}+    isSigned          :: a -> Bool++    bit i               = 1 `shiftL` i+    x `setBit` i        = x .|. bit i+    x `clearBit` i      = x .&. complement (bit i)+    x `complementBit` i = x `xor` bit i+    x `testBit` i       = (x .&. bit i) /= 0++    {-| Shift the argument left by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'shiftR' or the unified+	'shift', depending on which is more convenient for the type in+	question. -}+    shiftL            :: a -> Int -> a+    x `shiftL`  i = x `shift`  i++    {-| Shift the argument right (signed) by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'shiftL' or the unified+	'shift', depending on which is more convenient for the type in+	question. -}+    shiftR            :: a -> Int -> a+    x `shiftR`  i = x `shift`  (-i)++    {-| Rotate the argument left by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'rotateR' or the unified+	'rotate', depending on which is more convenient for the type in+	question. -}+    rotateL           :: a -> Int -> a+    x `rotateL` i = x `rotate` i++    {-| Rotate the argument right by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'rotateL' or the unified+	'rotate', depending on which is more convenient for the type in+	question. -}+    rotateR           :: a -> Int -> a+    x `rotateR` i = x `rotate` (-i)++++BITSINST(Int,a)+BITSINST(Int8,a)+BITSINST(Int16,a)+BITSINST(Int32,a)+BITSINST(Int64,a)+BITSINST(IntPtr,a)+BITSINST(IntMax,a)+BITSINST(Integer,a)++BITSINST(Word)+BITSINST(Word8)+BITSINST(Word16)+BITSINST(Word32)+BITSINST(Word64)+BITSINST(WordPtr)+BITSINST(WordMax)
+ lib/haskell-extras/Data/Bits.m4 view
@@ -0,0 +1,22 @@+m4_divert(-1)++m4_define(BITSINST,{{++instance Bits $1 where+    x .&. y = and$1 x y+    x .|. y = or$1 x y+    x `xor` y = xor$1 x y+    complement x = complement$1 x+    shiftL x i = shiftL$1 x i+    shiftR x i = shiftR$1 x i++foreign import primitive "And" and$1 :: $1 -> $1 -> $1+foreign import primitive "Or" or$1 :: $1 -> $1 -> $1+foreign import primitive "Xor" xor$1 :: $1 -> $1 -> $1+foreign import primitive "Shr$2" shiftR$1 :: $1 -> Int -> $1+foreign import primitive "Shl" shiftL$1 :: $1 -> Int -> $1+foreign import primitive "Com" complement$1 :: $1 -> $1++}})++m4_divert
+ lib/haskell-extras/Data/Char.hs view
@@ -0,0 +1,21 @@+module Data.Char (+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,+    digitToInt, intToDigit,+    toUpper, toLower,+    ord, chr,+    readLitChar, showLitChar, lexLitChar,++        -- ...and what the Prelude exports+    Char, String+    ) where++import Jhc.Basics+import Jhc.Enum+import Jhc.List+import Jhc.Num+import Jhc.Order+import Jhc.Show+import Jhc.Text.Read+import Prelude.Text+import Prelude.CType
+ lib/haskell-extras/Data/Complex.hs view
@@ -0,0 +1,105 @@+module Data.Complex(+    Complex((:+)),+    realPart,+    imagPart,+    conjugate,+    mkPolar,+    cis,+    polar,+    magnitude,+    phase+    )  where++import Jhc.Num+import Jhc.Class.Real++infix  6  :+++-- the standard says this should have a RealFloat constraint, but that is silly.+data  Complex a = !a :+ !a  deriving (Eq,Read,Show)++realPart, imagPart :: (RealFloat a) => Complex a -> a+realPart (x:+y)  =  x+imagPart (x:+y)  =  y++conjugate  :: (RealFloat a) => Complex a -> Complex a+conjugate (x:+y) =  x :+ (-y)++mkPolar  :: (RealFloat a) => a -> a -> Complex a+mkPolar r theta  =  r * cos theta :+ r * sin theta++cis  :: (RealFloat a) => a -> Complex a+cis theta  =  cos theta :+ sin theta++polar  :: (RealFloat a) => Complex a -> (a,a)+polar z  =  (magnitude z, phase z)++magnitude :: (RealFloat a) => Complex a -> a+magnitude (x:+y) =  scaleFloat k+     (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))+    where k  = max (exponent x) (exponent y)+          mk = - k++phase :: (RealFloat a) => Complex a -> a+phase (0 :+ 0) = 0+phase (x :+ y) = atan2 y x++instance  (RealFloat a) => Num (Complex a)  where+    (x:+y) + (x':+y') =  (x+x') :+ (y+y')+    (x:+y) - (x':+y') =  (x-x') :+ (y-y')+    (x:+y) * (x':+y') =  (x*x'-y*y') :+ (x*y'+y*x')+    negate (x:+y) =  negate x :+ negate y+    abs z =  magnitude z :+ 0+    signum (0 :+ 0) =  0+    signum z@(x:+y) =  x/r :+ y/r  where r = magnitude z+    fromInteger n =  fromInteger n :+ 0+    fromInt n =  fromInt n :+ 0++instance  (RealFloat a) => Fractional (Complex a)  where+    (x:+y) / (x':+y') =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d+       where x'' = scaleFloat k x'+             y'' = scaleFloat k y'+             k   = - max (exponent x') (exponent y')+             d   = x'*x'' + y'*y''+    fromRational a =  fromRational a :+ 0+    fromDouble a = fromDouble a :+ 0++instance  (RealFloat a) => Floating (Complex a) where+    pi             =  pi :+ 0+    exp (x:+y)     =  expx * cos y :+ expx * sin y+                      where expx = exp x+    log z          =  log (magnitude z) :+ phase z++    sqrt (0 :+ 0)  =  0+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)+                      where (u,v) = if x < 0 then (v',u') else (u',v')+                            v'    = abs y / (u'*2)+                            u'    = sqrt ((magnitude z + abs x) / 2)++    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))+                      where sinx  = sin x+                            cosx  = cos x+                            sinhy = sinh y+                            coshy = cosh y++    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)+                      where siny  = sin y+                            cosy  = cos y+                            sinhx = sinh x+                            coshx = cosh x++    asin z@(x:+y)  =  y':+(-x')+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))+    acos z@(x:+y)  =  y'':+(-x'')+                      where (x'':+y'') = log (z + ((-y'):+x'))+                            (x':+y')   = sqrt (1 - z*z)+    atan z@(x:+y)  =  y':+(-x')+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))++    asinh z        =  log (z + sqrt (1+z*z))+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    atanh z        =  log ((1+z) / sqrt (1-z*z))
+ lib/haskell-extras/Data/Dynamic.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_JHC -fffi #-}+module Data.Dynamic(Dynamic,toDyn,fromDyn,fromDynamic,dynApply,dynApp) where+++import Data.Typeable++data Obj++data Dynamic = Dynamic TypeRep Obj++instance Show Dynamic where+    showsPrec _ x s = "<Dynamic>" ++ s++-- | 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     -> Nothing++-- (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)+++foreign import primitive "unsafeCoerce" unsafeCoerce :: a -> b
+ lib/haskell-extras/Data/Function.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_JHC -fno-prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Function+-- Copyright   :  Nils Anders Danielsson 2006+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Simple combinators working solely on and with functions.++module Data.Function+  ( -- * "Prelude" re-exports+    id, const, (.), flip, ($)+    -- * Other combinators+  , fix+  , on+  ) where++import Jhc.Basics++infixl 0 `on`++-- | @'fix' f@ is the least fixed point of the function @f@,+-- i.e. the least defined @x@ such that @f x = x@.+fix :: (a -> a) -> a+fix f = let x = f x in x++-- | @(*) \`on\` f = \\x y -> f x * f y@.+--+-- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@.+--+-- Algebraic properties:+--+-- * @(*) \`on\` 'id' = (*)@ (if @(*) &#x2209; {&#x22a5;, 'const' &#x22a5;}@)+--+-- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@+--+-- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@++-- Proofs (so that I don't have to edit the test-suite):++--   (*) `on` id+-- =+--   \x y -> id x * id y+-- =+--   \x y -> x * y+-- = { If (*) /= _|_ or const _|_. }+--   (*)++--   (*) `on` f `on` g+-- =+--   ((*) `on` f) `on` g+-- =+--   \x y -> ((*) `on` f) (g x) (g y)+-- =+--   \x y -> (\x y -> f x * f y) (g x) (g y)+-- =+--   \x y -> f (g x) * f (g y)+-- =+--   \x y -> (f . g) x * (f . g) y+-- =+--   (*) `on` (f . g)+-- =+--   (*) `on` f . g++--   flip on f . flip on g+-- =+--   (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g+-- =+--   (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g)+-- =+--   \(*) -> (*) `on` g `on` f+-- = { See above. }+--   \(*) -> (*) `on` g . f+-- =+--   (\h (*) -> (*) `on` h) (g . f)+-- =+--   flip on (g . f)++on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+(*) `on` f = \x y -> f x * f y
+ lib/haskell-extras/Data/Functor.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_JHC -fno-prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functors: uniform action over a parameterized type, generalizing the+-- 'map' function on lists.++module Data.Functor+    (+      Functor(fmap, (<$)),+      (<$>),+    ) where++import Jhc.Monad++infixl 4 <$>++-- | An infix synonym for 'fmap'.+(<$>) :: Functor f => (a -> b) -> f a -> f b+(<$>) = fmap
+ lib/haskell-extras/Data/IORef.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS_JHC -funboxed-values -fno-prelude -funboxed-tuples -fffi #-}+module Data.IORef(+    IORef(),	      -- abstract, instance of: Eq+    newIORef,	      -- :: a -> IO (IORef a)+    readIORef,	      -- :: IORef a -> IO a+    writeIORef,	      -- :: IORef a -> a -> IO ()+    modifyIORef,      -- :: IORef a -> (a -> a) -> IO ()+    atomicModifyIORef,-- :: IORef a -> (a -> (a,b)) -> IO b+    ) where++import Jhc.Prim.Array+import Jhc.Basics+import Jhc.IO++data IORef a = IORef (MutArray_ a)++newRef__ a = newArray__ 1# a+writeRef__ m v = writeArray__ m 0# v+readRef__ m = readArray__ m 0#++-- {-# NOINLINE newIORef #-}+newIORef :: a -> IO (IORef a)+newIORef v = fromUIO $ \w -> case newRef__ v w of (# w', r #) -> (# w', IORef r #)++-- {-# NOINLINE readIORef #-}+readIORef :: IORef a -> IO a+readIORef (IORef r) = fromUIO $ \w -> readRef__ r w++-- {-# NOINLINE writeIORef #-}+writeIORef :: IORef a -> a -> IO ()+writeIORef (IORef r) v = fromUIO $ \w -> case writeRef__ r v w of w' -> (# w', () #)++--foreign import primitive eqRef__ :: Ref__ a -> Ref__ a -> Bool++--instance Eq (IORef a) where+--    (IORef x) == (IORef y) = eqRef__ x y++--{-# NOINLINE modifyIORef #-}+modifyIORef :: IORef a -> (a -> a) -> IO ()+modifyIORef (IORef ref) f = fromUIO $ \w -> case readRef__ ref w of+    (# w', a #) -> case writeRef__ ref (f a) w' of+        w'' -> (# w'', () #)++--{-# NOINLINE atomicModifyIORef #-}+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef (IORef r) f = fromUIO $ \w -> case readRef__ r w of+    (# w', a #) -> case f a of+        (a',b) -> case writeRef__ r a' w' of+            w'' -> (# w'', b #)
+ lib/haskell-extras/Data/Int.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Data.Int(Int,Int8,Int16,Int32,Int64,IntMax,IntPtr) where++import Jhc.Type.Word
+ lib/haskell-extras/Data/Ix.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Data.Ix ( Ix(range, index, inRange, rangeSize) ) where++import Jhc.Int+import Jhc.Enum+import Jhc.Order+import Jhc.Basics+import Jhc.Num+import Jhc.Tuples+import Jhc.IO++class  Ord a => Ix a  where+    range     :: (a,a) -> [a]+    index     :: (a,a) -> a -> Int+    inRange   :: (a,a) -> a -> Bool+    rangeSize :: (a,a) -> Int++    rangeSize b@(l,h) = case range b of+        [] -> zero+        _  -> index b h `plus` one+	-- NB: replacing "null (range b)" by  "not (l <= h)"+	-- fails if the bounds are tuples.  For example,+	-- 	(1,2) <= (2,1)+	-- but the range is nevertheless empty+	--	range ((1,2),(2,1)) = []++instance  Ix Char  where+    range (m,n)		= [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci `minus` fromEnum c+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++instance  Ix Int  where+    range (m,n)		= [m..n]+    index b@(m,n) i+        | inRange b i   =  i `minus` m+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (m,n) i     =  m <= i && i <= n++instance  (Ix a, Ix b)  => Ix (a,b) where+        range   ((l,l'),(u,u')) = [(i,i') | i <- range (l,u), i' <- range (l',u')]+        index   ((l,l'),(u,u')) (i,i') =  index (l,u) i * rangeSize (l',u') + index (l',u') i'+        inRange ((l,l'),(u,u')) (i,i') = inRange (l,u) i && inRange (l',u') i'++--instance  Ix Integer  where+--    range (m,n)		= [m..n]+--    index b@(m,n) i+--        | inRange b i   =  fromInteger (i - m)+--        | otherwise     =  error "Ix.index: Index out of range."+--    inRange (m,n) i     =  m <= i && i <= n++instance  Ix Bool  where+    range (m,n)		= [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci `minus` fromEnum c+        | otherwise     =  error "Ix.index: 'Bool' Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++instance  Ix Ordering  where+    range (m,n)		= [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci `minus` fromEnum c+        | otherwise     =  error "Ix.index: 'Ordering' Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++-- instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples+-- instance Ix Bool                  -- as derived+-- instance Ix Ordering              -- as derived+-- instance Ix ()                    -- as derived
+ lib/haskell-extras/Data/List.hs view
@@ -0,0 +1,329 @@+module Data.List (+    elemIndex, elemIndices,+    find, findIndex, findIndices,+    nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,+    union, unionBy, intersect, intersectBy,+    intersperse, transpose, partition, group, groupBy,+    inits, tails, isPrefixOf, isSuffixOf,+    mapAccumL, mapAccumR,+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,+    genericLength, genericTake, genericDrop,+    genericSplitAt, genericIndex, genericReplicate,+    zip4, zip5, zip6, zip7,+    zipWith4, zipWith5, zipWith6, zipWith7,+    unzip4, unzip5, unzip6, unzip7, unfoldr,++    foldl', foldl1',++    -- ...and what the Prelude exports+    -- []((:), []), -- This is built-in syntax+    map, (++), concat, filter,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3+    ) where++infix 5 \\++elemIndex               :: Eq a => a -> [a] -> Maybe Int+elemIndex x             =  findIndex (x ==)++elemIndices             :: Eq a => a -> [a] -> [Int]+elemIndices x           =  findIndices (x ==)++find    :: (a -> Bool) -> [a] -> Maybe a+find p xs =  case  filter p xs of+    (x:_) -> Just x+    [] -> Nothing++findIndex               :: (a -> Bool) -> [a] -> Maybe Int+findIndex p  xs           = case findIndices p xs of+    (x:_) -> Just x+    [] -> Nothing++findIndices             :: (a -> Bool) -> [a] -> [Int]+findIndices p xs        =  [ i | (x,i) <- zip xs [0..], p x ]++nub                     :: Eq a => [a] -> [a]+nub l                   = nub' l [] where+    nub' [] _           = []+    nub' (x:xs) ls+        | x `elem` ls   = nub' xs ls+        | otherwise     = x : nub' xs (x:ls)++--nub                     =  nubBy (==)++nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+nubBy eq l              = nubBy' l []+  where+    nubBy' [] _         = []+    nubBy' (y:ys) xs+       | elem_by eq y xs = nubBy' ys xs+       | otherwise       = y : nubBy' ys (y:xs)+    elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool+    elem_by _  _ []             =  False+    elem_by eq y (x:xs) =  x `eq` y || elem_by eq y xs++--nubBy eq []             =  []+--nubBy eq (x:xs)         =  x : nubBy eq (filter (\y -> not (eq x y)) xs)++delete                  :: Eq a => a -> [a] -> [a]+delete                  =  deleteBy (==)++deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy eq x []        = []+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++(\\)                    :: Eq a => [a] -> [a] -> [a]+(\\)                    =  foldl (flip delete)++deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++union                   :: Eq a => [a] -> [a] -> [a]+union                   =  unionBy (==)++unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+unionBy eq xs ys        =  xs ++ deleteFirstsBy eq (nubBy eq ys) xs++intersect               :: Eq a => [a] -> [a] -> [a]+intersect               =  intersectBy (==)++intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]++intersperse             :: a -> [a] -> [a]+intersperse sep []      =  []+intersperse sep [x]     =  [x]+intersperse sep (x:xs)  =  x : sep : intersperse sep xs++-- transpose is lazy in both rows and columns,+--       and works for non-rectangular 'matrices'+-- For example, transpose [[1,2],[3,4,5],[]]  =  [[1,3],[2,4],[5]]+-- Note that [h | (h:t) <- xss] is not the same as (map head xss)+--      because the former discards empty sublists inside xss+transpose                :: [[a]] -> [[a]]+transpose []             = []+transpose ([]     : xss) = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :+                           transpose (xs : [t | (h:t) <- xss])++partition               :: (a -> Bool) -> [a] -> ([a],[a])+partition p xs          =  (filter p xs, filter (not . p) xs)++-- group splits its list argument into a list of lists of equal, adjacent+-- elements.  e.g.,+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]+group                   :: Eq a => [a] -> [[a]]+group                   =  groupBy (==)++groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy eq []           =  []+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                           where (ys,zs) = span (eq x) xs++-- inits xs returns the list of initial segments of xs, shortest first.+-- e.g., inits "abc" == ["","a","ab","abc"]+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- tails xs returns the list of all final segments of xs, longest first.+-- e.g., tails "abc" == ["abc", "bc", "c",""]+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs++isPrefixOf               :: Eq a => [a] -> [a] -> Bool+isPrefixOf []     _      =  True+isPrefixOf _      []     =  False+isPrefixOf (x:xs) (y:ys) =  x == y && isPrefixOf xs ys++isSuffixOf              :: Eq a => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumL f s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumR f s []        =  (s, [])+mapAccumR f s (x:xs)    =  (s'', y:ys)+                           where (s'',y ) = f s' x+                                 (s', ys) = mapAccumR f s xs++unfoldr                 :: (b -> Maybe (a,b)) -> b -> [a]+unfoldr f b             = case f b of+                                Nothing    -> []+                                Just (a,b) -> a : unfoldr f b++sort                    :: (Ord a) => [a] -> [a]+sort                    =  sortBy compare++sortBy                  :: (a -> a -> Ordering) -> [a] -> [a]+sortBy cmp l = mergesort cmp l where+    mergesort :: (a -> a -> Ordering) -> [a] -> [a]+    mergesort cmp = mergesort' cmp . map wrap++    mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]+    mergesort' cmp [] = []+    mergesort' cmp [xs] = xs+    mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)++    merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]+    merge_pairs cmp [] = []+    merge_pairs cmp [xs] = [xs]+    merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss++    merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+    merge cmp xs [] = xs+    merge cmp [] ys = ys+    merge cmp (x:xs) (y:ys)+     = case x `cmp` y of+            GT -> y : merge cmp (x:xs)   ys+            _  -> x : merge cmp    xs (y:ys)++    wrap :: a -> [a]+    wrap x = [x]++-- sortBy cmp              =  foldr (insertBy cmp) []++insert                  :: (Ord a) => a -> [a] -> [a]+insert                  = insertBy compare++insertBy                :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertBy cmp x []       =  [x]+insertBy cmp x ys@(y:ys')+                        =  case cmp x y of+                                GT -> y : insertBy cmp x ys'+                                _  -> x : ys++maximumBy               :: (a -> a -> Ordering) -> [a] -> a+maximumBy cmp []        =  error "List.maximumBy: empty list"+maximumBy cmp xs        =  foldl1 max xs+                        where+                           max x y = case cmp x y of+                                        GT -> x+                                        _  -> y++minimumBy               :: (a -> a -> Ordering) -> [a] -> a+minimumBy cmp []        =  error "List.minimumBy: empty list"+minimumBy cmp xs        =  foldl1 min xs+                        where+                           min x y = case cmp x y of+                                        GT -> y+                                        _  -> x++genericLength           :: (Integral a) => [b] -> a+genericLength []        =  0+genericLength (x:xs)    =  1 + genericLength xs++genericTake             :: (Integral a) => a -> [b] -> [b]+genericTake _ []        =  []+genericTake 0 _         =  []+genericTake n (x:xs)+   | n > 0              =  x : genericTake (n-1) xs+   | otherwise          =  error "List.genericTake: negative argument"++genericDrop             :: (Integral a) => a -> [b] -> [b]+genericDrop 0 xs        =  xs+genericDrop _ []        =  []+genericDrop n (_:xs)+   | n > 0              =  genericDrop (n-1) xs+   | otherwise          =  error "List.genericDrop: negative argument"++genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])+genericSplitAt 0 xs     =  ([],xs)+genericSplitAt _ []     =  ([],[])+genericSplitAt n (x:xs)+   | n > 0              =  (x:xs',xs'')+   | otherwise          =  error "List.genericSplitAt: negative argument"+       where (xs',xs'') =  genericSplitAt (n-1) xs++genericIndex            :: (Integral a) => [b] -> a -> b+genericIndex (x:_)  0   =  x+genericIndex (_:xs) n+        | n > 0         =  genericIndex xs (n-1)+        | otherwise     =  error "List.genericIndex: negative argument"+genericIndex _ _        =  error "List.genericIndex: index too large"++genericReplicate        :: (Integral a) => a -> b -> [b]+genericReplicate n x    =  genericTake n (repeat x)++zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+zip4                    =  zipWith4 (,,,)++zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+zip5                    =  zipWith5 (,,,,)++zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+zip6                    =  zipWith6 (,,,,,)++zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+zip7                    =  zipWith7 (,,,,,,)++zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)+                        =  z a b c d : zipWith4 z as bs cs ds+zipWith4 _ _ _ _ _      =  []++zipWith5                :: (a->b->c->d->e->f) ->+                           [a]->[b]->[c]->[d]->[e]->[f]+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)+                        =  z a b c d e : zipWith5 z as bs cs ds es+zipWith5 _ _ _ _ _ _    =  []++zipWith6                :: (a->b->c->d->e->f->g) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)+                        =  z a b c d e f : zipWith6 z as bs cs ds es fs+zipWith6 _ _ _ _ _ _ _  =  []++zipWith7                :: (a->b->c->d->e->f->g->h) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)+                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs+zipWith7 _ _ _ _ _ _ _ _ = []++unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])+unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->+                                        (a:as,b:bs,c:cs,d:ds))+                                 ([],[],[],[])++unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])+unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es))+                                 ([],[],[],[],[])++unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])+unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))+                                 ([],[],[],[],[],[])++unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])+unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->+                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))+                         ([],[],[],[],[],[],[])++{-# RULES "sort/sort"  forall  xs . sort (sort xs) = sort xs #-}+{-# RULES "nub/nub"  forall  xs . nub (nub xs) = nub xs #-}++-- | A strict version of 'foldl'.+foldl'           :: (a -> b -> a) -> a -> [b] -> a+foldl' f z xs = lgo z xs where+    lgo z []     = z+    lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs++-- | A strict version of 'foldl1'+foldl1'                  :: (a -> a -> a) -> [a] -> a+foldl1' f (x:xs)         =  foldl' f x xs+foldl1' _ []             =  error "foldl1': empty list"
+ lib/haskell-extras/Data/Maybe.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Data.Maybe (+    Maybe(Nothing, Just),  maybe,  isJust,  isNothing,  fromJust,  fromMaybe,+    listToMaybe,  maybeToList,  catMaybes,  mapMaybe+    ) where++import Jhc.Maybe+import Jhc.Order+import Jhc.Basics+import Jhc.IO++isJust                 :: Maybe a -> Bool+isJust (Just a)        =  True+isJust Nothing         =  False++isNothing        :: Maybe a -> Bool+isNothing        =  not . isJust++fromJust               :: Maybe a -> a+fromJust (Just a)      =  a+fromJust Nothing       =  error "Maybe.fromJust: Nothing"++fromMaybe              :: a -> Maybe a -> a+fromMaybe d Nothing    =  d+fromMaybe d (Just a)   =  a++maybeToList            :: Maybe a -> [a]+maybeToList Nothing    =  []+maybeToList (Just a)   =  [a]++listToMaybe            :: [a] -> Maybe a+listToMaybe []         =  Nothing+listToMaybe (a:_)      =  Just a++catMaybes              :: [Maybe a] -> [a]+catMaybes ms           =  [ m | Just m <- ms ]++mapMaybe               :: (a -> Maybe b) -> [a] -> [b]+mapMaybe f             =  catMaybes . map f
+ lib/haskell-extras/Data/Monoid.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Monoid+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The Monoid class with various general-purpose instances.+--+--    Inspired by the paper+--    /Functional Programming with Overloading and+--        Higher-Order Polymorphism/,+--      Mark P Jones (<http://citeseer.ist.psu.edu/jones95functional.html>)+--        Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Data.Monoid (+        -- * Monoid typeclass+        Monoid(..),+        Dual(..),+        Endo(..),+        -- * Bool wrappers+        All(..),+        Any(..),+        -- * Num wrappers+        Sum(..),+        Product(..),+        -- * Maybe wrappers+        -- $MaybeExamples+        First(..),+        Last(..)+  ) where+++{-+-- just for testing+-- CI import Data.Maybe+-- CI import Test.QuickCheck+-- -}++-- ---------------------------------------------------------------------------+-- | The monoid class.+-- A minimal complete definition must supply 'mempty' and 'mappend',+-- and these should satisfy the monoid laws.++class Monoid a where+        mempty  :: a+        -- ^ Identity of 'mappend'+        mappend :: a -> a -> a+        -- ^ An associative operation+        mconcat :: [a] -> a++        -- ^ Fold a list using the monoid.+        -- For most types, the default definition for 'mconcat' will be+        -- used, but the function is included in the class definition so+        -- that an optimized version can be provided for specific types.++        mconcat = foldr mappend mempty++-- Monoid instances.++instance Monoid [a] where+        mempty  = []+        mappend = (++)++instance Monoid b => Monoid (a -> b) where+        mempty _ = mempty+        mappend f g x = f x `mappend` g x++instance Monoid () where+        -- Should it be strict?+        mempty        = ()+        _ `mappend` _ = ()+        mconcat _     = ()++instance (Monoid a, Monoid b) => Monoid (a,b) where+        mempty = (mempty, mempty)+        (a1,b1) `mappend` (a2,b2) =+                (a1 `mappend` a2, b1 `mappend` b2)++instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where+        mempty = (mempty, mempty, mempty)+        (a1,b1,c1) `mappend` (a2,b2,c2) =+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)++instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where+        mempty = (mempty, mempty, mempty, mempty)+        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =+                (a1 `mappend` a2, b1 `mappend` b2,+                 c1 `mappend` c2, d1 `mappend` d2)++instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>+                Monoid (a,b,c,d,e) where+        mempty = (mempty, mempty, mempty, mempty, mempty)+        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,+                 d1 `mappend` d2, e1 `mappend` e2)++-- lexicographical ordering+instance Monoid Ordering where+        mempty         = EQ+        LT `mappend` _ = LT+        EQ `mappend` y = y+        GT `mappend` _ = GT++-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.+newtype Dual a = Dual { getDual :: a }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Monoid a => Monoid (Dual a) where+        mempty = Dual mempty+        Dual x `mappend` Dual y = Dual (y `mappend` x)++-- | The monoid of endomorphisms under composition.+newtype Endo a = Endo { appEndo :: a -> a }++instance Monoid (Endo a) where+        mempty = Endo id+        Endo f `mappend` Endo g = Endo (f . g)++-- | Boolean monoid under conjunction.+newtype All = All { getAll :: Bool }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Monoid All where+        mempty = All True+        All x `mappend` All y = All (x && y)++-- | Boolean monoid under disjunction.+newtype Any = Any { getAny :: Bool }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Monoid Any where+        mempty = Any False+        Any x `mappend` Any y = Any (x || y)++-- | Monoid under addition.+newtype Sum a = Sum { getSum :: a }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Num a => Monoid (Sum a) where+        mempty = Sum 0+        Sum x `mappend` Sum y = Sum (x + y)++-- | Monoid under multiplication.+newtype Product a = Product { getProduct :: a }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Num a => Monoid (Product a) where+        mempty = Product 1+        Product x `mappend` Product y = Product (x * y)++-- $MaybeExamples+-- To implement @find@ or @findLast@ on any 'Foldable':+--+-- @+-- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a+-- findLast pred = getLast . foldMap (\x -> if pred x+--                                            then Last (Just x)+--                                            else Last Nothing)+-- @+--+-- Much of Data.Map's interface can be implemented with+-- Data.Map.alter. Some of the rest can be implemented with a new+-- @alterA@ function and either 'First' or 'Last':+--+-- > alterA :: (Applicative f, Ord k) =>+-- >           (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)+-- >+-- > instance Monoid a => Applicative ((,) a)  -- from Control.Applicative+--+-- @+-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v+--                     -> Map k v -> (Maybe v, Map k v)+-- insertLookupWithKey combine key value =+--   Arrow.first getFirst . alterA doChange key+--   where+--   doChange Nothing = (First Nothing, Just value)+--   doChange (Just oldValue) =+--     (First (Just oldValue),+--      Just (combine key value oldValue))+-- @++-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to+-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be+-- turned into a monoid simply by adjoining an element @e@ not in @S@+-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since+-- there is no \"Semigroup\" typeclass providing just 'mappend', we+-- use 'Monoid' instead.+instance Monoid a => Monoid (Maybe a) where+  mempty = Nothing+  Nothing `mappend` m = m+  m `mappend` Nothing = m+  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)++-- | Maybe monoid returning the leftmost non-Nothing value.+newtype First a = First { getFirst :: Maybe a }+#ifndef __HADDOCK__+        deriving (Eq, Ord, Read, Show)+#else  /* __HADDOCK__ */+instance Eq a => Eq (First a)+instance Ord a => Ord (First a)+instance Read a => Read (First a)+instance Show a => Show (First a)+#endif++instance Monoid (First a) where+        mempty = First Nothing+        r@(First (Just _)) `mappend` _ = r+        First Nothing `mappend` r = r++-- | Maybe monoid returning the rightmost non-Nothing value.+newtype Last a = Last { getLast :: Maybe a }+#ifndef __HADDOCK__+        deriving (Eq, Ord, Read, Show)+#else  /* __HADDOCK__ */+instance Eq a => Eq (Last a)+instance Ord a => Ord (Last a)+instance Read a => Read (Last a)+instance Show a => Show (Last a)+#endif++instance Monoid (Last a) where+        mempty = Last Nothing+        _ `mappend` r@(Last (Just _)) = r+        r `mappend` Last Nothing = r++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (Maybe a) where+  arbitrary = oneof [return Nothing, Just `fmap` arbitrary]++prop_mconcatMaybe :: [Maybe [Int]] -> Bool+prop_mconcatMaybe x =+  fromMaybe [] (mconcat x) == mconcat (catMaybes x)++prop_mconcatFirst :: [Maybe Int] -> Bool+prop_mconcatFirst x =+  getFirst (mconcat (map First x)) == listToMaybe (catMaybes x)+prop_mconcatLast :: [Maybe Int] -> Bool+prop_mconcatLast x =+  getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x)+        where listLastToMaybe [] = Nothing+              listLastToMaybe lst = Just (last lst)+-- -}
+ lib/haskell-extras/Data/Typeable.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS_JHC -fffi -funboxed-values  #-}+module Data.Typeable(TypeRep(),Typeable(..),Typeable1(..),Typeable2(..)) where++import Jhc.Prim+import Jhc.String++type String_ = BitsPtr_++data TypeRep = TypeRep String_ [TypeRep]++showsAddr__ :: String_ -> [Char] -> [Char]+showsAddr__ a xs = unpackStringFoldr a (:) xs++instance Show TypeRep where+    showsPrec _ (TypeRep a []) = showsAddr__ a+    showsPrec n (TypeRep a xs) = showParen (n > 9) $ spacesep (showsAddr__ a:map (showsPrec 10) xs) where+        spacesep [] = id+        spacesep [x] = x+        spacesep (x:xs) = x . showChar ' ' . spacesep xs++instance Eq TypeRep where+    TypeRep a xs == TypeRep b ys = case c_strcmp (Addr_ a) (Addr_ b) of+        0 -> xs == ys+        _ -> False++foreign import ccall "strcmp" c_strcmp :: Addr_ -> Addr_ -> Int++{-+foreign import primitive ptypeOf :: a -> TypeRep+foreign import primitive ptypeOf1 :: t a -> TypeRep+foreign import primitive ptypeOf2 :: t a b -> TypeRep+foreign import primitive ptypeOf3 :: t a b c -> TypeRep+foreign import primitive ptypeOf4 :: t a b c d -> TypeRep+foreign import primitive ptypeOf5 :: t a b c d e -> TypeRep+foreign import primitive ptypeOf6 :: t a b c d e f -> TypeRep+foreign import primitive ptypeOf7 :: t a b c d e f g -> TypeRep+foreign import primitive typeRepEq :: TypeRep -> TypeRep -> Bool+-}++class Typeable a where+    typeOf :: a -> TypeRep++class Typeable1 f where+    typeOf1 :: f a -> TypeRep++class Typeable2 f where+    typeOf2 :: f a b -> TypeRep++instance Typeable1 [] where+    typeOf1 _ = TypeRep "[]"# []++instance Typeable a => Typeable [a] where+    typeOf x = typeOfDefault x++{-+instance (Typeable a,Typeable b) => Typeable (a -> b) where+    typeOf x = (typeOf2 x `mkAppTy` arg1 x) `mkAppTy` arg2 x where+        arg1 :: (x -> y) -> x+        arg2 :: (x -> y) -> y+        arg1 = undefined+        arg2 = undefined++instance (Typeable a) => Typeable1 ((->) a) where+    typeOf1 x = typeOf1Default x++instance Typeable2 (->) where+    typeOf2 _ = TypeRep "->"# []+-}++instance Typeable2 (,) where+    typeOf2 _ = TypeRep "(,)"# []++instance Typeable a => Typeable1 ((,) a) where+    typeOf1 x = typeOf1Default x++instance (Typeable b,Typeable a) => Typeable (a,b) where+    typeOf x = typeOfDefault x++instance Typeable Char where+    typeOf _ = TypeRep "Char"# []++instance Typeable () where+    typeOf _ = TypeRep "()"# []++instance Typeable Int where+    typeOf _ = TypeRep "Int"# []++--instance (Typeable1 f,Typeable a) => Typeable (f a) where+--    typeOf x = typeOf1 x `mkAppTy` typeOf (argType x) where+--        argType :: a b -> b+--        argType = undefined++mkAppTy :: TypeRep -> TypeRep -> TypeRep+mkAppTy (TypeRep x xs) tr = TypeRep x (xs ++ [tr])++-------------------------------------------------------------+--+--		Type-safe cast+--+-------------------------------------------------------------++unsafeCoerce :: a -> b+unsafeCoerce = unsafeCoerce__++-- | The type-safe cast operation+cast :: (Typeable a, Typeable b) => a -> Maybe b+cast x = r where+    fromJust (Just x) = x+    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+  -}++-- | 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++-- | 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
+ lib/haskell-extras/Data/Unicode.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_JHC -fffi #-}+module Data.Unicode(+    CType(),+    ctype,+    isCType,+    t_alnum,+    t_alpha,+    t_blank,+    t_cntrl,+    t_digit,+    t_graph,+    t_lower,+    t_print,+    t_punct,+    t_space,+    t_upper,+    t_xdigit,+    t_none+    )where++import Foreign.C.String+import Foreign.C.Types+import System.IO.Unsafe++newtype CType = CType CInt++-- | Get a ctype other than one of the defaults.++ctype :: String -> IO CType+ctype s = withCString s c_wctype++isCType :: Char -> CType -> Bool+isCType ch ct = unsafePerformIO (c_iswctype ch ct) /= 0+++t_alnum, t_alpha, t_blank, t_cntrl,+ t_digit, t_graph, t_lower, t_print,+ t_punct, t_space, t_upper, t_xdigit, t_none :: CType++t_alnum = unsafePerformIO (ctype "alnum")+t_alpha = unsafePerformIO (ctype "alpha")+t_blank = unsafePerformIO (ctype "blank")+t_cntrl = unsafePerformIO (ctype "cntrl")+t_digit = unsafePerformIO (ctype "digit")+t_graph = unsafePerformIO (ctype "graph")+t_lower = unsafePerformIO (ctype "lower")+t_print = unsafePerformIO (ctype "print")+t_punct = unsafePerformIO (ctype "punct")+t_space = unsafePerformIO (ctype "space")+t_upper = unsafePerformIO (ctype "upper")+t_xdigit = unsafePerformIO (ctype "xdigit")+t_none = CType 0++{-# NOINLINE+ t_alnum, t_alpha, t_blank, t_cntrl,+ t_digit, t_graph, t_lower, t_print,+ t_punct, t_space, t_upper, t_xdigit+ #-}+++foreign import ccall "wctype.h iswctype" c_iswctype :: Char -> CType -> IO Int+foreign import ccall "wctype.h wctype" c_wctype :: CString -> IO CType+
+ lib/haskell-extras/Data/Unique.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_JHC  -fffi  #-}+module Data.Unique (+   -- * Unique objects+   Unique(),            -- instance (Eq, Ord)+   newUnique,           -- :: IO Unique+   hashUnique           -- :: Unique -> Int+ ) where++import Foreign.Storable+import Foreign.Ptr++-- | An abstract unique object.  Objects of type 'Unique' may be+-- compared for equality and ordering and hashed into 'Int'.+newtype Unique = Unique Int deriving (Eq,Ord)+++-- | Creates a new object of type 'Unique'.  The value returned will+-- not compare equal to any other value of type 'Unique' returned by+-- previous calls to 'newUnique'.  There is no limit on the number of+-- times 'newUnique' may be called.+newUnique :: IO Unique+newUnique = do+    n <- peek c_data_unique+    poke c_data_unique (n + 1)+    return $ Unique n++-- | Hashes a 'Unique' into an 'Int'.  Two 'Unique's may hash to the+-- same value, although in practice this is unlikely.  The 'Int'+-- returned makes a good hash key.+hashUnique :: Unique -> Int+hashUnique (Unique u) = u+++instance Show Unique where+    showsPrec p (Unique n) = showsPrec p n++foreign import ccall "&jhc_data_unique" c_data_unique :: Ptr Int+
+ lib/haskell-extras/Data/Version.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Version+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification in ReadP)+--+-- A general library for representation and manipulation of versions.+--+-- Versioning schemes are many and varied, so the version+-- representation provided by this library is intended to be a+-- compromise between complete generality, where almost no common+-- functionality could reasonably be provided, and fixing a particular+-- versioning scheme, which would probably be too restrictive.+--+-- So the approach taken here is to provide a representation which+-- subsumes many of the versioning schemes commonly in use, and we+-- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String'+-- which will be appropriate for some applications, but not all.+--+-----------------------------------------------------------------------------++module Data.Version (+        -- * The @Version@ type+        Version(..),+        -- * A concrete representation of @Version@+        showVersion+  ) where++import Data.List ( sort, intersperse )++{- |+A 'Version' represents the version of a software entity.++An instance of 'Eq' is provided, which implements exact equality+modulo reordering of the tags in the 'versionTags' field.++An instance of 'Ord' is also provided, which gives lexicographic+ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2,+etc.).  This is expected to be sufficient for many uses, but note that+you may need to use a more specific ordering for your versioning+scheme.  For example, some versioning schemes may include pre-releases+which have tags @\"pre1\"@, @\"pre2\"@, and so on, and these would need to+be taken into account when determining ordering.  In some cases, date+ordering may be more appropriate, so the application would have to+look for @date@ tags in the 'versionTags' field and compare those.+The bottom line is, don't always assume that 'compare' and other 'Ord'+operations are the right thing for every 'Version'.++Similarly, concrete representations of versions may differ.  One+possible concrete representation is provided (see 'showVersion' and+'parseVersion'), but depending on the application a different concrete+representation may be more appropriate.+-}+data Version =+  Version { versionBranch :: [Int],+                -- ^ The numeric branch for this version.  This reflects the+                -- fact that most software versions are tree-structured; there+                -- is a main trunk which is tagged with versions at various+                -- points (1,2,3...), and the first branch off the trunk after+                -- version 3 is 3.1, the second branch off the trunk after+                -- version 3 is 3.2, and so on.  The tree can be branched+                -- arbitrarily, just by adding more digits.+                --+                -- We represent the branch as a list of 'Int', so+                -- version 3.2.1 becomes [3,2,1].  Lexicographic ordering+                -- (i.e. the default instance of 'Ord' for @[Int]@) gives+                -- the natural ordering of branches.++           versionTags :: [String]  -- really a bag+                -- ^ A version can be tagged with an arbitrary list of strings.+                -- The interpretation of the list of tags is entirely dependent+                -- on the entity that this version applies to.+        }+  deriving ( Read,Show )++instance Eq Version where+  v1 == v2  =  versionBranch v1 == versionBranch v2+                && sort (versionTags v1) == sort (versionTags v2)+                -- tags may be in any order++instance Ord Version where+  v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2++-- -----------------------------------------------------------------------------+-- A concrete representation of 'Version'++-- | Provides one possible concrete representation for 'Version'.  For+-- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags'+-- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@.+--+showVersion :: Version -> String+showVersion (Version branch tags)+  = concat (intersperse "." (map show branch)) +++     concatMap ('-':) tags
+ lib/haskell-extras/Data/Word.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Data.Word(Word,Word8,Word16,Word32,Word64,WordMax,WordPtr) where++import Jhc.Type.Word
+ lib/haskell-extras/Debug/Trace.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Debug.Trace+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'trace' function.+--+-----------------------------------------------------------------------------++module Debug.Trace (+        -- * Tracing+        putTraceMsg,      -- :: String -> IO ()+        trace,            -- :: String -> a -> a+        traceShow+  ) where++import System.IO.Unsafe+import System.IO (hPutStrLn,stderr)++-- | 'putTraceMsg' function outputs the trace message from IO monad.+-- Usually the output stream is 'System.IO.stderr' but if the function is called+-- from Windows GUI application then the output will be directed to the Windows+-- debug console.+putTraceMsg :: String -> IO ()+putTraceMsg msg = do+    hPutStrLn stderr msg++{-# NOINLINE trace #-}+{-|+When called, 'trace' outputs the string in its first argument, before+returning the second argument as its result. The 'trace' function is not+referentially transparent, and should only be used for debugging, or for+monitoring execution. Some implementations of 'trace' may decorate the string+that\'s output to indicate that you\'re tracing. The function is implemented on+top of 'putTraceMsg'.+-}+trace :: String -> a -> a+trace string expr = unsafePerformIO $ do+    putTraceMsg string+    return expr++{-|+Like 'trace', but uses 'show' on the argument to convert it to a 'String'.++> traceShow = trace . show+-}+traceShow :: (Show a) => a -> b -> b+traceShow = trace . show
+ lib/haskell-extras/Foreign.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_JHC -fno-prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of data types, classes, and functions for interfacing+-- with another programming language.+--+-----------------------------------------------------------------------------++module Foreign+        ( module Data.Bits+        , module Data.Int+        , module Data.Word+	, module Foreign.Ptr+        , module Foreign.ForeignPtr+        , module Foreign.StablePtr+        , module Foreign.Storable+        , module Foreign.Marshal++        -- | For compatibility with the FFI addendum only.  The recommended+        -- place to get this from is "System.IO.Unsafe".+        , unsafePerformIO+        ) where++import Data.Bits+import Data.Int+import Data.Word+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Foreign.Storable+import Foreign.Marshal++import System.IO.Unsafe (unsafePerformIO)
+ lib/haskell-extras/Foreign/C.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.C+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Bundles the C specific FFI library functionality+--+-----------------------------------------------------------------------------++module Foreign.C+        ( module Foreign.C.Types+        , module Foreign.C.String+        , module Foreign.C.Error+        ) where++import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error
+ lib/haskell-extras/Foreign/ForeignPtr.hs view
@@ -0,0 +1,70 @@+module Foreign.ForeignPtr(+    ForeignPtr,  FinalizerPtr,  FinalizerEnvPtr,  newForeignPtr,+    newForeignPtr_,  addForeignPtrFinalizer,  newForeignPtrEnv,+    addForeignPtrFinalizerEnv,  withForeignPtr,  finalizeForeignPtr,+    unsafeForeignPtrToPtr,  touchForeignPtr,  castForeignPtr,+    mallocForeignPtr,  mallocForeignPtrBytes,  mallocForeignPtrArray,+    mallocForeignPtrArray0+    ) where++import Control.Monad+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import Jhc.IO+import Jhc.ForeignPtr++type FinalizerPtr  a = FunPtr (Ptr a -> IO ())++newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)+newForeignPtr finalizer ptr = do+    fp <- newForeignPtr_ ptr+    addForeignPtrFinalizer finalizer fp+    return fp++addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()+addForeignPtrFinalizer _ _ = return ()++mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes sz = mallocForeignPtrAlignBytes 0 sz++mallocForeignPtr :: Storable a => IO (ForeignPtr a)+mallocForeignPtr = doMalloc undefined where+    doMalloc :: Storable b => b -> IO (ForeignPtr b)+    doMalloc x = mallocForeignPtrAlignBytes (alignment x) (sizeOf x)++mallocForeignPtrArray  :: Storable a => Int -> IO (ForeignPtr a)+mallocForeignPtrArray  = doMalloc undefined where+    doMalloc            :: Storable a' => a' -> Int -> IO (ForeignPtr a')+    doMalloc dummy size  = mallocForeignPtrAlignBytes+        (alignment dummy) (size * sizeOf dummy)++mallocForeignPtrArray0  :: Storable a => Int -> IO (ForeignPtr a)+mallocForeignPtrArray0 sz = mallocForeignPtrArray (sz + 1)++withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+withForeignPtr fp act = do+    r <- act (unsafeForeignPtrToPtr fp)+    touchForeignPtr fp+    return r++-- |A finalizer is represented as a pointer to a foreign function that, at+-- finalisation time, gets as an argument a plain pointer variant of the+-- foreign pointer that the finalizer is associated with.+type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())++-- | This variant of newForeignPtr adds a finalizer that expects an environment in addition to the finalized pointer. The environment that will be passed to the finalizer is fixed by the second argument to newForeignPtrEnv.+newForeignPtrEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a)+newForeignPtrEnv f e p = do+    fp <- newForeignPtr_ p+    addForeignPtrFinalizerEnv f e fp+    return fp++-- | Like addForeignPtrFinalizerEnv but allows the finalizer to be passed an additional environment parameter to be passed to the finalizer. The environment passed to the finalizer is fixed by the second argument to addForeignPtrFinalizerEnv+addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()+addForeignPtrFinalizerEnv _ _ _ = return ()++-- | Causes the finalizers associated with a foreign pointer to be run immediately.+finalizeForeignPtr :: ForeignPtr a -> IO ()+finalizeForeignPtr _ = return ()
+ lib/haskell-extras/Foreign/Marshal.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fno-implicit-prelude #-}+{-# OPTIONS_JHC -fno-prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal+-- Copyright   :  (c) The FFI task force 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support+--+-----------------------------------------------------------------------------++module Foreign.Marshal+        ( module Foreign.Marshal.Alloc+        , module Foreign.Marshal.Array+        , module Foreign.Marshal.Error+        , module Foreign.Marshal.Pool+        , module Foreign.Marshal.Utils+        ) where++import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Error+import Foreign.Marshal.Pool+import Foreign.Marshal.Utils
+ lib/haskell-extras/Foreign/Marshal/Error.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Error+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Routines for testing return values and raising a 'userError' exception+-- in case of values indicating an error state.+--+-----------------------------------------------------------------------------++module Foreign.Marshal.Error (+  throwIf,       -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO a+  throwIf_,      -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO ()+  throwIfNeg,    -- :: (Ord a, Num a)+	         -- =>                (a -> String) -> IO a       -> IO a+  throwIfNeg_,   -- :: (Ord a, Num a)+	         -- =>                (a -> String) -> IO a       -> IO ()+  throwIfNull,   -- ::                String        -> IO (Ptr a) -> IO (Ptr a)++  -- Discard return value+  void           -- IO a -> IO ()+) where++import Foreign.Ptr++-- exported functions+-- ------------------++-- |Execute an 'IO' action, throwing a 'userError' if the predicate yields+-- 'True' when applied to the result returned by the 'IO' action.+-- If no exception is raised, return the result of the computation.+--+throwIf :: (a -> Bool)	-- ^ error condition on the result of the 'IO' action+	-> (a -> String) -- ^ computes an error message from erroneous results+			-- of the 'IO' action+	-> IO a		-- ^ the 'IO' action to be executed+	-> IO a+throwIf pred msgfct act  = do+    res <- act+    (if pred res then ioError . userError . msgfct else return) res++-- |Like 'throwIf', but discarding the result+--+throwIf_                 :: (a -> Bool) -> (a -> String) -> IO a -> IO ()+throwIf_ pred msgfct act  = void $ throwIf pred msgfct act++-- |Guards against negative result values+--+throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a+throwIfNeg  = throwIf (< 0)++-- |Like 'throwIfNeg', but discarding the result+--+throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO ()+throwIfNeg_  = throwIf_ (< 0)++-- |Guards against null pointers+--+throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)+throwIfNull  = throwIf (== nullPtr) . const++-- |Discard the return value of an 'IO' action+--+void     :: IO a -> IO ()+void act  = act >> return ()
+ lib/haskell-extras/Foreign/Marshal/Pool.hs view
@@ -0,0 +1,190 @@+{-# OPTIONS_GHC -fno-implicit-prelude #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Pool+-- Copyright   :  (c) Sven Panne 2002-2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  sven.panne@aedion.de+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains support for pooled memory management. Under this scheme,+-- (re-)allocations belong to a given pool, and everything in a pool is+-- deallocated when the pool itself is deallocated. This is useful when+-- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation+-- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'+-- and 'free' are too awkward.+--+-- modified by John Meacham to use unboxed linked lists directly+--+--------------------------------------------------------------------------------++module Foreign.Marshal.Pool(+   -- * Pool management+   Pool(),+   newPool,             -- :: IO Pool+   freePool,            -- :: Pool -> IO ()+   withPool,            -- :: (Pool -> IO b) -> IO b++   -- * (Re-)Allocation within a pool+   pooledMalloc,        -- :: Storable a => Pool                 -> IO (Ptr a)+   pooledMallocBytes,   -- ::               Pool          -> Int -> IO (Ptr a)++   pooledRealloc,       -- :: Storable a => Pool -> Ptr a        -> IO (Ptr a)+   pooledReallocBytes,  -- ::               Pool -> Ptr a -> Int -> IO (Ptr a)++   pooledMallocArray,   -- :: Storable a => Pool ->          Int -> IO (Ptr a)+   pooledMallocArray0,  -- :: Storable a => Pool ->          Int -> IO (Ptr a)++   pooledReallocArray,  -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+   pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)++   -- * Combined allocation and marshalling+   pooledNew,           -- :: Storable a => Pool -> a            -> IO (Ptr a)+   pooledNewArray,      -- :: Storable a => Pool ->      [a]     -> IO (Ptr a)+   pooledNewArray0      -- :: Storable a => Pool -> a -> [a]     -> IO (Ptr a)+) where++import Control.Exception     ( bracket )+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array ( pokeArray, pokeArray0 )+import Foreign.Ptr+import Foreign.Storable++--------------------------------------------------------------------------------++-- To avoid non-H98 stuff like existentially quantified data constructors, we+-- simply use pointers to () below. Not very nice, but...++-- | A memory pool.++++newtype Pool = Pool (Ptr (Ptr ())) -- (IORef [Ptr ()])++-- | Allocate a fresh memory pool.++newPool :: IO Pool+newPool = do+    pool <- malloc+    poke pool nullPtr+    return $ Pool pool++-- | Deallocate a memory pool and everything which has been allocated in the+-- pool itself.++freePool :: Pool -> IO ()+freePool (Pool pool) = f pool where+    f p = do+        v <- peek p+        free p+        if v == nullPtr then return () else f (castPtr v :: Ptr (Ptr ()))++-- | Execute an action with a fresh memory pool, which gets automatically+-- deallocated (including its contents) after the action has finished.++withPool :: (Pool -> IO b) -> IO b+withPool = bracket newPool freePool++--------------------------------------------------------------------------------++-- | Allocate space for storable type in the given pool. The size of the area+-- allocated is determined by the 'sizeOf' method from the instance of+-- 'Storable' for the appropriate type.++pooledMalloc :: Storable a => Pool -> IO (Ptr a)+pooledMalloc = pm undefined+  where+    pm           :: Storable a' => a' -> Pool -> IO (Ptr a')+    pm dummy pool = pooledMallocBytes pool (sizeOf dummy)++-- | Allocate the given number of bytes of storage in the pool.++pooledMallocBytes :: Pool -> Int -> IO (Ptr a)+pooledMallocBytes (Pool pool) size = do+    ptr <- mallocBytes (size + sizeOf pool)+    v <- peek pool+    poke ptr v+    return (castPtr $ ptr `plusPtr` sizeOf pool)++-- | Adjust the storage area for an element in the pool to the given size of+-- the required type.++pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)+pooledRealloc = pr undefined+  where+    pr               :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')+    pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)++-- | Adjust the storage area for an element in the pool to the given size.++pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocBytes = error "pools don't support reallocing the size" --(Pool pool) ptr size = do+--   let cPtr = castPtr ptr+--   throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)+--   newPtr <- reallocBytes cPtr size+--   ptrs <- readIORef pool+--   writeIORef pool (newPtr : delete cPtr ptrs)+--   return (castPtr newPtr)++-- | Allocate storage for the given number of elements of a storable type in the+-- pool.++pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)+pooledMallocArray = pma undefined+  where+    pma                :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')+    pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)++-- | Allocate storage for the given number of elements of a storable type in the+-- pool, but leave room for an extra element to signal the end of the array.++pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)+pooledMallocArray0 pool size =+   pooledMallocArray pool (size + 1)++-- | Adjust the size of an array in the given pool.++pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocArray = pra undefined+  where+    pra                ::  Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')+    pra dummy pool ptr size  = pooledReallocBytes pool ptr (size * sizeOf dummy)++-- | Adjust the size of an array with an end marker in the given pool.++pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocArray0 pool ptr size =+   pooledReallocArray pool ptr (size + 1)++--------------------------------------------------------------------------------++-- | Allocate storage for a value in the given pool and marshal the value into+-- this storage.++pooledNew :: Storable a => Pool -> a -> IO (Ptr a)+pooledNew pool val = do+   ptr <- pooledMalloc pool+   poke ptr val+   return ptr++-- | Allocate consecutive storage for a list of values in the given pool and+-- marshal these values into it.++pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)+pooledNewArray pool vals = do+   ptr <- pooledMallocArray pool (length vals)+   pokeArray ptr vals+   return ptr++-- | Allocate consecutive storage for a list of values in the given pool and+-- marshal these values into it, terminating the end with the given marker.++pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)+pooledNewArray0 pool marker vals = do+   ptr <- pooledMallocArray0 pool (length vals)+   pokeArray0 marker ptr vals+   return ptr++
+ lib/haskell-extras/Foreign/StablePtr.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-tuples #-}+module Foreign.StablePtr(+    StablePtr(),+    castStablePtrToPtr,+    castPtrToStablePtr,+    newStablePtr,+    deRefStablePtr,+    freeStablePtr+    ) where++import Jhc.Prim.Rts+import Jhc.IO+import Jhc.Type.Ptr+import Jhc.Basics++data StablePtr a++castPtrToStablePtr :: Ptr () -> StablePtr a+castPtrToStablePtr (Ptr (Addr_ p)) = fromBang_ (bangFromRaw p)++castStablePtrToPtr :: StablePtr a -> Ptr ()+castStablePtrToPtr p = Ptr (Addr_ (bangToRaw (toBang_ p)))++freeStablePtr :: StablePtr a -> IO ()+freeStablePtr p = c_freeStablePtr (toBang_ p)++-- | newStablePtr will seq its argument to get rid of nasty GC issues and be+-- compatible with FFI calling conventions, if this is an issue, you can put an+-- extra box around it.+newStablePtr :: a -> IO (StablePtr a)+newStablePtr x = do+    fromUIO $ \w -> case c_newStablePtr (toBang_ x) w of+        (# w', s #) -> (# w', fromBang_ s #)++deRefStablePtr :: StablePtr a -> IO a+deRefStablePtr x = do+    fromUIO $ \w -> case c_derefStablePtr (toBang_ x) w of+        (# w', s #) -> (# w', fromBang_ s #)++foreign import ccall unsafe "rts/stableptr.c c_freeStablePtr"  c_freeStablePtr   :: Bang_ (StablePtr a) -> IO ()+foreign import ccall unsafe "rts/stableptr.c c_newStablePtr"   c_newStablePtr    :: Bang_ a -> UIO (Bang_ (StablePtr a))+foreign import ccall unsafe "rts/stableptr.c c_derefStablePtr" c_derefStablePtr :: Bang_ (StablePtr a) -> UIO (Bang_ a)
+ lib/haskell-extras/Prelude.hs view
@@ -0,0 +1,270 @@+{-# OPTIONS_JHC -funboxed-tuples #-}+module Prelude(+    -- Prelude+    Bool(False, True),+    Maybe(Nothing, Just),+    Either(Left, Right),+    Ordering(LT, EQ, GT),+    Char, String, Int, Integer, Float, Double, Rational, IO,+    module Jhc.Basics, -- for list+--  List type: []((:), [])+--  Tuple types: (,)((,)), (,,)((,,)), etc.+--  Trivial type: ()(())+--  Functions: (->)++    Eq((==), (/=)),+    Ord(compare, (<), (<=), (>=), (>), max, min),+    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,+         enumFromTo, enumFromThenTo),+    Bounded(minBound, maxBound),+    Num((+), (-), (*), negate, abs, signum, fromInteger),+    Real(toRational),+    Integral(quot, rem, div, mod, quotRem, divMod, toInteger),+    Fractional((/), recip, fromRational),+    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,+             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),+    RealFrac(properFraction, truncate, round, ceiling, floor),+    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,+              encodeFloat, exponent, significand, scaleFloat, isNaN,+              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<),+    maybe, either,+    (&&), (||), not, otherwise,+    subtract, even, odd, gcd, lcm, (^), (^^),+    fromIntegral, realToFrac,+    fst, snd, curry, uncurry, id, const, (.), flip, ($), until,+    asTypeOf, error, undefined,+    seq, ($!),++    -- PreludeList+    map, (++), filter, concat, concatMap,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum,+    zip, zip3, zipWith, zipWith3, unzip, unzip3,++    -- PreludeText+    ReadS, ShowS,+    Read(readsPrec, readList),+    Show(showsPrec, show, showList),+    reads, shows, read, lex,+    showChar, showString, readParen, showParen,++    -- PreludeIO+    FilePath, IOError, ioError, userError, catch,+    putChar, putStr, putStrLn, print,+    getChar, getLine, getContents, interact,+    readFile, writeFile, appendFile, readIO, readLn+    ) where++import Jhc.Basics+import Jhc.Float++import Jhc.Inst.Enum()+import Jhc.Inst.Num()+import Jhc.Inst.Order()+import Jhc.Inst.Read()+import Jhc.Inst.Show()+import Jhc.Inst.Storable()+import Jhc.Tuples()++import Jhc.Enum+import Jhc.IO+import Jhc.List+import Jhc.Maybe+import Jhc.Monad+import Jhc.Num+import Jhc.Numeric+import Jhc.Order+import Prelude.IO+import Prelude.Text+import qualified Prelude.CType as Char+--import qualified Data.Char as Char(isSpace,ord,chr)++import Jhc.Class.Real++--infixr 9  .+--infixr 8  ^, ^^, **+--infixr 8  ^, ^^+--infixl 7  *  , /, `quot`, `rem`, `div`, `mod`+--infixl 6  +, -+--infixr 5  :+--infix  4  ==, /=, <, <=, >=, >+--infixr 3  &&+--infixr 2  ||+--infixl 1  >>, >>=+--infixr 1  =<<+--infixr 0  $, $!, `seq`++either :: (a -> c) -> (b -> c) -> Either a b -> c+either f g (Left x)  =  f x+either f g (Right y) =  g y++until :: (a -> Bool) -> (a -> a) -> a -> a+until p f x+     | p x       =  x+     | otherwise =  until p f (f x)++-- foldl, applied to a binary operator, a starting value (typically the+-- left-identity of the operator), and a list, reduces the list using+-- the binary operator, from left to right:+--  foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn+-- foldl1 is a variant that has no starting value argument, and  thus must+-- be applied to non-empty lists.  scanl is similar to foldl, but returns+-- a list of successive reduced values from the left:+--      scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+-- Note that  last (scanl f z xs) == foldl f z xs.+-- scanl1 is similar, again without the starting element:+--      scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]++-- cycle ties a finite list into a circular one, or equivalently,+-- the infinite repetition of the original list.  It is the identity+-- on infinite lists.++cycle            :: [a] -> [a]+cycle []         =  error "Prelude.cycle: empty list"+cycle xs         =  xs' where xs' = xs ++ xs'++-- lines breaks a string up into a list of strings at newline characters.+-- The resulting strings do not contain newlines.  Similary, words+-- breaks a string up into a list of words, which were delimited by+-- white space.  unlines and unwords are the inverse operations.+-- unlines joins lines with terminating newlines, and unwords joins+-- words with separating spaces.++lines            :: String -> [String]+lines ""         =  []+lines s          =  let (l, s') = break (== '\n') s+                      in  l : case s' of+                                []      -> []+                                (_:s'') -> lines s''++words            :: String -> [String]+words s          =  case dropWhile Char.isSpace s of+                      "" -> []+                      s' -> w : words s''+                            where (w, s'') = break Char.isSpace s'++unlines          :: [String] -> String+unlines [] = []+unlines (l:ls) = l ++ '\n' : unlines ls+--unlines          =  concatMap (++ "\n")++unwords          :: [String] -> String+unwords []		=  ""+unwords [w]		= w+unwords (w:ws)		= w ++ ' ' : unwords ws++-- lookup key assocs looks up a key in an association list.++{- SPECIALIZE lookup :: forall b . Char -> (Char,b) -> Maybe b #-}+{- SPECIALIZE lookup :: forall b . Int -> (Int,b) -> Maybe b #-}++lookup           :: (Eq a) => a -> [(a,b)] -> Maybe b+lookup key []    =  Nothing+lookup key ((x,y):xys)+    | key == x   =  Just y+    | otherwise  =  f x y xys where+        f x y _ | key == x = Just y+        f _ _ ((x,y):xys)  = f x y xys+        f _ _ []           = Nothing++-- sum and product compute the sum or product of a finite list of numbers.++sum, product     :: (Num a) => [a] -> a+--sum              =  foldl (+) 0+--product          =  foldl (*) 1+sum l	= sum' l 0 where+    sum' []     a = a+    sum' (x:xs) a = sum' xs (a+x)+product	l = prod l 1 where+    prod []     a = a+    prod (x:xs) a = prod xs (a*x)++sum' l	= rsum l 0 where+    rsum []     a = a+    rsum (x:xs) a = a `seq` rsum xs (a+x)++{-# SPECIALIZE sum' :: [Int] -> Int #-}+{-# RULES "sum/Int" forall . sum = sum' :: [Int] -> Int #-}+{-# SPECIALIZE sum' :: [Double] -> Double #-}+{-# RULES "sum/Double" forall . sum = sum' :: [Double] -> Double #-}++-- maximum and minimum return the maximum or minimum value from a list,+-- which must be non-empty, finite, and of an ordered type.++maximum, minimum :: (Ord a) => [a] -> a+maximum []       =  error "Prelude.maximum: empty list"+maximum xs       =  foldl1 max xs++minimum []       =  error "Prelude.minimum: empty list"+minimum xs       =  foldl1 min xs++zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]+zip3             =  zipWith3 (\a b c -> (a,b,c))++zipWith3         :: (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith3 z (a:as) (b:bs) (c:cs)+                 =  z a b c : zipWith3 z as bs cs+zipWith3 _ _ _ _ =  []++-- unzip transforms a list of pairs into a pair of lists.++unzip            :: [(a,b)] -> ([a],[b])+unzip            =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])++unzip3           :: [(a,b,c)] -> ([a],[b],[c])+unzip3           =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+                          ([],[],[])++{-# RULES "drop/0"        forall . drop 0 = \xs -> xs #-}+{-# RULES "drop/1"        forall x xs . drop 1 (x:xs) = xs #-}+{-# RULES "drop/2"        forall x y xs . drop 2 (x:y:xs) = xs #-}+{-# RULES "drop/3"        forall x y z xs . drop 3 (x:y:z:xs) = xs #-}+{-# RULES "take/0"        forall xs . take 0 xs = [] #-}+{-# RULES "take/1"        forall x xs . take 1 (x:xs) = [x] #-}+{-# RULES "take/2"        forall x y xs . take 2 (x:y:xs) = [x,y] #-}+{-# RULES "take/3"        forall x y z xs . take 3 (x:y:z:xs) = [x,y,z] #-}+{-# RULES "!!/0"          forall x xs . (x:xs) !! 0 = x #-}+{-# RULES "!!/1"          forall x y xs . (x:y:xs) !! 1 = y #-}+{-# RULES "!!/2"          forall x y z xs . (x:y:z:xs) !! 2 = z #-}+{-# RULES "concat/Map"    forall f xs . concat (map f xs) = concatMap f xs #-}+{-# RULES "sequence/map"  forall f xs . sequence (map f xs) = mapM f xs #-}+{-# RULES "sequence_/map" forall f xs . sequence_ (map f xs) = mapM_ f xs #-}+{-# RULES "++/emptyr"     forall xs . xs ++ [] = xs #-}+{-# RULES "++/refix"      forall xs ys zs . (xs ++ ys) ++ zs = xs ++ (ys ++ zs) #-}+--{-# RULES "++/tick4"      forall x y z x' xs ys . (x:y:z:x':xs) ++ ys = x:y:z:x':(xs ++ ys) #-}+--{-# RULES "++/tick2"      forall x y xs ys . (x:y:xs) ++ ys = x:y:(xs ++ ys) #-}+--{-# RULES "++/tick1"      forall x xs ys . (x:xs) ++ ys = x:(xs ++ ys) #-}+{-# RULES "++/tick0"      forall xs . [] ++ xs = xs #-}+{-# RULES "++/tick1"      forall x xs . [x] ++ xs = x:xs #-}+{-# RULES "++/tick2"      forall x y xs . [x,y] ++ xs = x:y:xs #-}+{-# RULES "++/tick3"      forall x y z xs . [x,y,z] ++ xs = x:y:z:xs #-}+{-# RULES "map/map"       forall f g xs . map f (map g xs) = map (\x -> f (g x)) xs #-}+{-# RULES "concatMap/map" forall f g xs . concatMap f (map g xs) = concatMap (\x -> f (g x)) xs #-}+{---# RULES "concat/tick"   forall x xs . concat (x:xs) = x ++ concat xs #-}+{-# RULES "concat/[]"     concat [] = [] #-}+{-# RULES "map/[]"        forall f . map f [] = [] #-}+{-# RULES "concatMap/[]"  forall f . concatMap f [] = [] #-}+{-# RULES "concatMap/++"  forall xs ys f . concatMap f (xs ++ ys) = concatMap f xs ++ concatMap f ys #-}+{-# RULES "map/++"        forall xs ys f . map f (xs ++ ys) = map f xs ++ map f ys #-}++{-# RULES "foldr/map" forall k z f xs . foldr k z (map f xs) = foldr (\x y -> k (f x) y) z xs #-}+{-# RULES "foldr/concatMap" forall k z f xs . foldr k z (concatMap f xs) = foldr (\x y -> foldr k (f x) y) z xs #-}+{-# RULES "foldr/filter" forall k z f xs . foldr k z (filter f xs) = foldr (\x y -> if f x then k x y else y) z xs #-}+{-# RULES "foldr/++" forall k z xs ys . foldr k z (xs ++ ys) = foldr k (foldr k z ys) xs #-}+{-# RULES "foldr/concat" forall k z xs . foldr k z (concat xs) = foldr (\x y -> foldr k y x) z xs #-}+{-# RULES "foldr/repeat" forall k _z x . foldr k _z (repeat x) = let r = k x r in r #-}+-- causes horrible code bloat+-- {-# RULES "foldr/x:xs" forall k z x xs . foldr k z (x:xs) = k x (foldr k z xs) #-}+{-# RULES "foldr/zip" forall k z xs ys . foldr k z (zip xs ys) = let zip' (a:as) (b:bs) = k (a,b) (zip' as bs); zip' _ _ = z in zip' xs ys #-}+-- {-# RULES "foldr/sequence" forall k z xs . foldr k z (sequence xs) = foldr (\x y -> do rx <- x; ry <- y; return (k rx ry)) (return z) xs #-}+-- {-# RULES "foldr/mapM" forall k z f xs . foldr k z (mapM f xs) = foldr (\x y -> do rx <- f x; ry <- y; return (k rx ry)) (return z) xs   #-}++default(Int,Double)
+ lib/haskell-extras/System/CPUTime.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.CPUTime+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The standard CPUTime library.+--+-----------------------------------------------------------------------------++module System.CPUTime (+    getCPUTime,+    cpuTimePrecision+    ) where+++-- |Computation 'getCPUTime' returns the number of picoseconds CPU time+-- used by the current program.  The precision of this result is+-- implementation-dependent.+getCPUTime :: IO Integer+getCPUTime = error "getCPUTime"++-- |The 'cpuTimePrecision' constant is the smallest measurable difference+-- in CPU time that the implementation can record, and is given as an+-- integral number of picoseconds.+cpuTimePrecision :: Integer+cpuTimePrecision = error "cpuTimePrecision"+
+ lib/haskell-extras/System/Cmd.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_JHC -fffi #-}+module System.Cmd ( system ) where++import Foreign.C.String+import Foreign.C.Types+import System.Exit ( ExitCode(..) )++system      :: String -> IO ExitCode++system s = withCString s c_system >>= \r -> case r of+    0 -> return ExitSuccess+    _ -> return $ ExitFailure (fromIntegral r)++foreign import unsafe ccall "system" c_system :: CString -> IO CInt
+ lib/haskell-extras/System/Console/GetOpt.hs view
@@ -0,0 +1,301 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Console.GetOpt+-- Copyright   :  (c) Sven Panne 2002-2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- This library provides facilities for parsing the command-line options+-- in a standalone program.  It is essentially a Haskell port of the GNU+-- @getopt@ library.+--+-----------------------------------------------------------------------------++{-+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+  are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+  compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example!+:-)+-}++module System.Console.GetOpt (+   -- * GetOpt+   getOpt,+   usageInfo,+   ArgOrder(..),+   OptDescr(..),+   ArgDescr(..),++   -- * Example++   -- $example+) where++import Data.List ( isPrefixOf )++-- |What to do with options following non-options+data ArgOrder a+  = RequireOrder                -- ^ no option processing after first non-option+  | Permute                     -- ^ freely intersperse options and non-options+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options++{-|+Each 'OptDescr' describes a single option.++The arguments to 'Option' are:++* list of short option characters++* list of long option strings (without \"--\")++* argument descriptor++* explanation of option for user+-}+data OptDescr a =              -- description of a single options:+   Option [Char]                --    list of short option characters+          [String]              --    list of long option strings (without "--")+          (ArgDescr a)          --    argument descriptor+          String                --    explanation of option for user++-- |Describes whether an option takes an argument or not, and if so+-- how the argument is injected into a value of type @a@.+data ArgDescr a+   = NoArg                   a         -- ^   no argument expected+   | ReqArg (String       -> a) String -- ^   option requires argument+   | OptArg (Maybe String -> a) String -- ^   optional argument++data OptKind a                -- kind of cmd line arg (internal use only):+   = Opt       a                --    an option+   | NonOpt    String           --    a non-option+   | EndOfOpts                  --    end-of-options marker (i.e. "--")+   | OptErr    String           --    something went wrong...++-- | Return a string describing the usage of a command, derived from+-- the header (first argument) and the options described by the+-- second argument.+usageInfo :: String                    -- header+          -> [OptDescr a]              -- option descriptors+          -> String                    -- nicely formatted decription of options+usageInfo header optDescr = unlines (header:table)+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> [(String,String,String)]+fmtOpt (Option sos los ad descr) =+   case lines descr of+     []     -> [(sosFmt,losFmt,"")]+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]+   where sepBy _  []     = ""+         sepBy _  [x]    = x+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs+         sosFmt = sepBy ',' (map (fmtShort ad) sos)+         losFmt = sepBy ',' (map (fmtLong  ad) los)++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++{-|+Process the command-line, and return the list of values that matched+(and those that didn\'t). The arguments are:++* The order requirements (see 'ArgOrder')++* The option descriptions (see 'OptDescr')++* The actual command line arguments (presumably got from+  'System.Environment.getArgs').++'getOpt' returns a triple, consisting of the argument values, a list+of options that didn\'t match, and a list of error messages.+-}+getOpt :: ArgOrder a                   -- non-option handling+       -> [OptDescr a]                 -- option descriptors+       -> [String]                     -- the commandline arguments+       -> ([a],[String],[String])      -- (options,non-options,error messages)+getOpt _        _        []         =  ([],[],[])+getOpt ordering optDescr (arg:args) = procNextOpt opt ordering+   where procNextOpt (Opt o)    _                 = (o:os,xs,es)+         procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])+         procNextOpt (NonOpt x) Permute           = (os,x:xs,es)+         procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)+         procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])+         procNextOpt EndOfOpts  Permute           = ([],rest,[])+         procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])+         procNextOpt (OptErr e) _                 = (os,xs,e:es)++         (opt,rest) = getNext arg args optDescr+         (os,xs,es) = getOpt ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a            rest _        = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+   where (opt,arg) = break (=='=') ls+         getWith p = [ o  | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `p` l ]+         exact     = getWith (==)+         options   = if null exact then getWith isPrefixOf else exact+         ads       = [ ad | Option _ _ ad _ <- options ]+         optStr    = ("--"++opt)++         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)+         long [NoArg  a  ] []       rest     = (Opt a,rest)+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)+         long [ReqArg _ d] []       []       = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)+         long _            _        rest     = (errUnrec optStr,rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x xs rest optDescr = short ads xs rest+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+        ads     = [ ad | Option _ _ ad _ <- options ]+        optStr  = '-':[x]++        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)+        short (NoArg  a  :_) [] rest     = (Opt a,rest)+        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)+        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)+        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)+        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)+        short []             [] rest     = (errUnrec optStr,rest)+        short []             xs rest     = (errUnrec optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> OptKind a+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show++options :: [OptDescr Flag]+options =+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing  = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"+                        (_,_,errs) -> concat errs ++ usageInfo header options+   where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+--    ==> options=[Verbose]  args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+--    ==> options=[Arg "foo", Verbose]  args=[]+-- putStr (test Permute ["foo","--","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]+-- putStr (test Permute ["--ver","foo"])+--    ==> option `--ver' is ambiguous; could be one of:+--          -v      --verbose             verbosely list files+--          -V, -?  --version, --release  show version info+--        Usage: foobar [OPTION...] files...+--          -v        --verbose             verbosely list files+--          -V, -?    --version, --release  show version info+--          -o[FILE]  --output[=FILE]       use FILE for dump+--          -n USER   --name=USER           only dump USER's files+-----------------------------------------------------------------------------------------+-}++{- $example++To hopefully illuminate the role of the different data+structures, here\'s the command-line options for a (very simple)+compiler:++>    module Opts where+>+>    import System.Console.GetOpt+>    import Data.Maybe ( fromMaybe )+>+>    data Flag+>     = Verbose  | Version+>     | Input String | Output String | LibDir String+>       deriving Show+>+>    options :: [OptDescr Flag]+>    options =+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"+>     ]+>+>    inp,outp :: Maybe String -> Flag+>    outp = Output . fromMaybe "stdout"+>    inp  = Input  . fromMaybe "stdout"+>+>    compilerOpts :: [String] -> IO ([Flag], [String])+>    compilerOpts argv =+>       case (getOpt Permute options argv) of+>          (o,n,[]  ) -> return (o,n)+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+>      where header = "Usage: ic [OPTION...] files..."++-}
+ lib/haskell-extras/System/Directory.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_JHC -fffi #-}+module System.Directory (+    Permissions( Permissions, readable, writable, executable, searchable ),+    createDirectory, removeDirectory, removeFile,+    renameDirectory, renameFile, getDirectoryContents,+    getCurrentDirectory, setCurrentDirectory,+    doesFileExist, doesDirectoryExist,+    getPermissions, setPermissions,+    getModificationTime ) where++import Foreign+import Foreign.C++import System.Time++data Permissions = Permissions {+    readable,   writable,+    executable, searchable :: !Bool+   } deriving (Eq,Ord,Read,Show)++cPathMax :: CSize+cPathMax = 1024++getCurrentDirectory  :: IO FilePath+getCurrentDirectory = allocaBytes (fromIntegral cPathMax) $ \cp -> do+    cp <- throwErrnoIfNull "getCurrentDirectory" (getcwd cp cPathMax)+    peekCString cp+++setCurrentDirectory :: FilePath -> IO ()+setCurrentDirectory fp = throwErrnoIfMinus1_ fp $ withCString fp chdir++foreign import ccall unsafe chdir :: CString -> IO Int+foreign import ccall unsafe getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)+foreign import ccall unsafe mkdir :: CString -> Int -> IO Int+foreign import ccall unsafe rmdir :: CString -> IO Int+foreign import ccall unsafe unlink :: CString -> IO Int+foreign import ccall unsafe rename :: CString -> CString -> IO Int+++createDirectory  :: FilePath -> IO ()+createDirectory fp = throwErrnoIfMinus1_ fp $ withCString fp $ \cs -> mkdir cs (-1)+++removeDirectory  :: FilePath -> IO ()+removeDirectory fp = throwErrnoIfMinus1_ fp $ withCString fp rmdir+++removeFile  :: FilePath -> IO ()+removeFile fp = throwErrnoIfMinus1_ fp $ withCString fp unlink+++renameDirectory  :: FilePath -> FilePath -> IO ()+renameDirectory fp1 fp2 = throwErrnoIfMinus1_ "rename" $ do+    withCString fp1 $ \fp1 -> do+    withCString fp2 $ \fp2 -> do+    rename fp1 fp2++renameFile  :: FilePath -> FilePath -> IO ()+renameFile x y = renameDirectory x y++getDirectoryContents  :: FilePath -> IO [FilePath]+getDirectoryContents = error "getDirectoryContents"+++doesFileExist :: FilePath -> IO Bool+doesFileExist = error "doesFileExist"++doesDirectoryExist :: FilePath -> IO Bool+doesDirectoryExist = error "doesDirectoryExist"++getPermissions :: FilePath -> IO Permissions+getPermissions = error "getPermissions"++setPermissions :: FilePath -> Permissions -> IO ()+setPermissions = error "setPermissions"++getModificationTime :: FilePath -> IO ClockTime+getModificationTime = error "getModificationTime"+++
+ lib/haskell-extras/System/Environment.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_JHC -fffi #-}+module System.Environment+    (+      getArgs,       -- :: IO [String]+      getProgName,   -- :: IO String+      getEnv,        -- :: String -> IO String+      getEnvironment -- :: IO [(String,String)]+  ) where++import Foreign.C.String+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.C.Types+import qualified Jhc.Options++getArgs     :: IO [String]+getProgName :: IO String+getEnv      :: String -> IO String++getProgName = case Jhc.Options.target of+    Jhc.Options.GhcHs -> ghc_getProgName+    _ -> peek ajhc_progname >>= peekCString++getArgs = case Jhc.Options.target of+    Jhc.Options.GhcHs -> ghc_getArgs+    _ -> do+        argc <- peek ajhc_argc+        argv <- peek ajhc_argv+        let f n = peekElemOff argv n >>= peekCString+        mapM f [0 .. fromIntegral argc - 1]++getEnv s = withCString s c_getenv >>= \p ->+    if p == nullPtr then fail ("getEnv: " ++ show s)  else peekCString p++foreign import unsafe ccall "stdlib.h getenv" c_getenv :: Ptr CChar -> IO (Ptr CChar)++foreign import ccall "&jhc_progname" ajhc_progname :: Ptr CString+foreign import ccall "&jhc_argc" ajhc_argc :: Ptr CInt+foreign import ccall "&jhc_argv" ajhc_argv :: Ptr (Ptr CString)++ghc_getArgs :: IO [String]+ghc_getArgs =+    alloca $ \ p_argc ->+    alloca $ \ p_argv -> do+        getProgArgv p_argc p_argv+        p    <- peek p_argc+        argv <- peek p_argv+        let f n = peekElemOff argv n >>= peekCString+        mapM f [1 .. fromIntegral p - 1]++foreign import unsafe ccall "getProgArgv"+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++ghc_getProgName :: IO String+ghc_getProgName =+  alloca $ \ p_argc ->+  alloca $ \ p_argv -> do+     getProgArgv p_argc p_argv+     argv <- peek p_argv+     peekElemOff argv 0 >>= peekCString++-- |'getEnvironment' retrieves the entire environment as a+-- list of @(key,value)@ pairs.+--+-- If an environment entry does not contain an @\'=\'@ character,+-- the @key@ is the whole entry and the @value@ is the empty string.++getEnvironment :: IO [(String, String)]+getEnvironment = do+   pBlock <- peek c_environ+   if pBlock == nullPtr then return []+    else do+      stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString+      return (map divvy stuff)+  where+   divvy str =+      case break (=='=') str of+        (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)+        (name,_:value) -> (name,value)++foreign import ccall "&environ" c_environ :: Ptr (Ptr CString)
+ lib/haskell-extras/System/Exit.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_JHC -fffi #-}+module System.Exit (+    ExitCode(ExitSuccess,ExitFailure),+    exitWith, exitFailure, exitSuccess+    ) where++import Jhc.IO(exitFailure)++data ExitCode = ExitSuccess | ExitFailure !Int+            deriving (Eq, Ord, Read, Show)++-- exitFailure :: IO a+exitSuccess :: IO a+exitSuccess = exitWith ExitSuccess++exitWith    :: ExitCode -> IO a+exitWith ExitSuccess = do+    c_exit 0+    return undefined+exitWith (ExitFailure n) = do+    c_exit n+    return undefined++foreign import unsafe ccall "exit" c_exit :: Int -> IO ()
+ lib/haskell-extras/System/IO.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_JHC -fffi #-}+module System.IO(+    module System.IO.Error,+    BufferMode(..),+    Handle,+    IOMode(..),+    SeekMode(..),+    hClose,+    hFileSize,+    hSeek,+    hTell,+    hFlush,+    hGetBuf,+    hGetPosn,+    hSetPosn,+    hGetContents,+    hGetChar,+    hGetLine,+    hIsOpen,+    hIsClosed,+    hPrint,+    hPutBuf,+    hPutChar,+    hPutStr,+    hPutStrLn,+    hIsEOF,+    isEOF,+    hWaitForInput,+    openFile,+    openBinaryFile,+    withFile,+    fixIO,+    HandlePosn,+    stdin,stdout,stderr,+    hIsReadable,+    hIsSeekable,+    hIsWritable,+    hLookAhead,+    hReady,+    hSetBuffering,+    hGetBuffering+    ) where++import Foreign.Ptr+import Jhc.Handle+import Jhc.IO+import Jhc.Num+import Jhc.Type.C+import System.C.Stdio++data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)+    deriving(Eq, Ord, Read, Show)+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd+    deriving(Eq,Ord,Bounded,Enum,Read,Show)++type HandlePosn = Integer++hIsReadable h = return $ handleIOMode h `elem` [ReadMode,ReadWriteMode]+hIsWritable h = return $ handleIOMode h `elem` [AppendMode,WriteMode,ReadWriteMode]++withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFile fp iom action = do+    h <- openFile fp iom+    r <- action h+    hClose h+    return r++hIsClosed h = not `fmap` hIsOpen h++hFlush :: Handle -> IO ()+hFlush h = withHandle h c_fflush++isEOF :: IO Bool+isEOF = hIsEOF stdin++hIsEOF :: Handle -> IO Bool+hIsEOF h = withHandle h $ \ptr -> do+    r <- c_feof ptr+    return (r /= 0)++hWaitForInput :: Handle -> Int -> IO Bool+hWaitForInput h to = withHandle h $ \ptr -> c_wait_for_input ptr to++hPutChar h ch = withHandle h $ \ptr -> do+    c_fputwc (fromInt (ord ch)) ptr+    return ()++hPutStr     :: Handle -> String -> IO ()+hPutStr h s   = withHandle h $ \ptr -> do+    sequence_ [ c_fputwc (fromInt (ord ch)) ptr | ch <- s ]++hPutStrLn   :: Handle -> String -> IO ()+hPutStrLn h s = do+    hPutStr h s+    hPutChar h '\n'++hPrint      :: Show a => Handle -> a -> IO ()+hPrint h x  =  hPutStrLn h (show x)++hGetLine    :: Handle -> IO String+hGetLine h  =  do c <- hGetChar h+                  if c == '\n' then return "" else+                    do s <- hGetLine h+                       return (c:s)++hGetChar :: Handle -> IO Char+hGetChar h = withHandle h $ \ptr -> do+    ch <- c_fgetwc ptr+    case ch of+        -1 -> fail "hGetChar: EOF"+        _  -> return (unsafeChr ch)++hGetContents :: Handle -> IO String+hGetContents h = withHandle h $ \ptr -> do+    let getContents' = do+            ch <- c_fgetwc ptr+            case ch of+                -1 -> return []+                _ -> do+                    xs <- unsafeInterleaveIO getContents'+                    return (unsafeChr ch:xs)+    unsafeInterleaveIO getContents'++hTell :: Handle -> IO Integer+hTell h = withHandle h $ \ptr -> fmap fromIntegral (c_ftell ptr)++hSeek :: Handle -> SeekMode -> Integer -> IO ()+hSeek h v w = withHandle h $ \ptr -> do+    let sm x = case x of+            AbsoluteSeek -> c_SEEK_SET+            RelativeSeek -> c_SEEK_CUR+            SeekFromEnd  -> c_SEEK_END+    c_fseek ptr (fromIntegral w) (sm v)+    return ()++hGetPosn :: Handle -> IO HandlePosn+hGetPosn h = hTell h++hSetPosn :: Handle -> HandlePosn -> IO ()+hSetPosn h hp = hSeek h AbsoluteSeek hp++hPutBuf :: Handle -> Ptr a -> Int -> IO ()+hPutBuf h p c = do+    let count = fromIntegral c+    rc <- withHandle h $ c_fwrite p 1 count+    if rc /= count then fail "hPutBuf: short write" else return ()++hGetBuf :: Handle -> Ptr a -> Int -> IO Int+hGetBuf h p c = do+    let count = fromIntegral c+    rc <- withHandle h $ c_fread p 1 count+    return $ fromIntegral rc++hIsSeekable :: Handle -> IO Bool+hIsSeekable _ = return True++hLookAhead :: Handle -> IO Char+hLookAhead = error "hLookAhead"++hReady :: Handle -> IO Bool+hReady _ = return True++hSetBuffering :: Handle -> BufferMode -> IO ()+hSetBuffering _ _ = return ()++hGetBuffering :: Handle -> IO BufferMode+hGetBuffering _ = error "hGetBuffering"++hFileSize :: Handle -> IO Integer+hFileSize h = do+    cp <- hTell h+    hSeek h SeekFromEnd 0+    fl <- hTell h+    hSeek h AbsoluteSeek cp+    return fl++foreign import primitive "I2I" cwintToChar :: CWint -> Char+foreign import ccall "jhc_wait_for_input" c_wait_for_input :: FILE -> Int -> IO Bool
+ lib/haskell-extras/System/IO/Binary.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_JHC -fffi -funboxed-values #-}+module System.IO.Binary(readBinaryFile,putWord8,getWord8) where++import Jhc.IO+import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr+import Foreign.C.Error++-- | Lazily read a file as a sequence of bytes.++readBinaryFile :: FilePath -> IO [Word8]+readBinaryFile fn = do+    file <- withCString fn $ \fnc -> c_fopen fnc "rb"#+    if  (file == nullPtr) then getErrno >>= \errno -> (ioError $ errnoToIOError "readBinaryFile" errno Nothing (Just fn)) else do+        let gc = do+                ch <- c_getc file+                case ch of+                    -1 -> c_fclose file >> return []+                    _ -> do+                        xs <- unsafeInterleaveIO gc+                        return (cintToWord8 ch:xs)+        unsafeInterleaveIO gc++foreign import primitive "Lobits" cintToWord8 :: CInt -> Word8+--foreign import primitive "const.\"rb\"" read_str :: Ptr CChar++foreign import ccall "stdio.h getc_unlocked" c_getc :: Ptr () -> IO CInt+foreign import ccall "stdio.h fopen" c_fopen :: CString -> BitsPtr_ -> IO (Ptr ())+foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt++-- Int translates to CInt in the calling conventions so this is safe.+foreign import ccall "stdio.h putchar_unlocked" c_putchar :: Int -> IO Int+foreign import ccall "stdio.h getchar_unlocked" c_getchar :: IO Int++putWord8 :: Word8 -> IO ()+putWord8 w = c_putchar (fromIntegral w) >> return ()++getWord8 :: IO Word8+getWord8 = do+    c <- c_getchar+    case c of+        -1 -> fail "EOF"+        _ -> return $ fromIntegral c
+ lib/haskell-extras/System/IO/Continuation.hs view
@@ -0,0 +1,19 @@+module System.IO.Continuation(IOCont(),newContinuation,callContinuation) where++import Jhc.JumpPoint+import Jhc.Hole++data IOCont s a = IOCont (Hole a) JumpPoint++newContinuation :: (forall s . IOCont s a -> IO b) -> (a -> IO b) -> IO b+newContinuation act cc = do+    ref <- newHole+    withJumpPoint__ $ \jp r -> case r of+        False -> do act (IOCont ref jp)+        True  -> do readHole ref >>= cc++callContinuation :: IOCont s a -> a -> IO b+callContinuation (IOCont ref jp) x = do+    fillHole ref x+    jumpJumpPoint__ jp+
+ lib/haskell-extras/System/IO/Error.hs view
@@ -0,0 +1,100 @@+module System.IO.Error (+    IOError(),  userError,  mkIOError,  annotateIOError,  isAlreadyExistsError,+    isDoesNotExistError,  isAlreadyInUseError,  isFullError,  isEOFError,+    isIllegalOperation,  isPermissionError,  isUserError,  ioeGetErrorString,+    ioeGetHandle,  ioeGetFileName,  IOErrorType(),  alreadyExistsErrorType,+    doesNotExistErrorType,  alreadyInUseErrorType,  fullErrorType,+    eofErrorType,  illegalOperationErrorType,  permissionErrorType,+    userErrorType,  ioError,  catch,  try+  ) where++import Jhc.Type.Handle++-- | The construct 'try' @comp@ exposes IO errors which occur within a+-- computation, and which are not fully handled.+--+-- Non-I\/O exceptions are not caught by this variant; to catch all+-- exceptions, use 'Control.Exception.try' from "Control.Exception".++try            :: IO a -> IO (Either IOError a)+try f          =  catch (do r <- f+                            return (Right r))+                        (return . Left)++-- -----------------------------------------------------------------------------+-- Constructing an IOError++-- | Construct an 'IOError' of the given type where the second argument+-- describes the error location and the third and fourth argument+-- contain the file handle and file path of the file involved in the+-- error if applicable.+mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> IOError+mkIOError = IOError++-- TODO(john): fix+annotateIOError :: IOError -> String -> Maybe Handle -> Maybe FilePath -> IOError+annotateIOError ioe _s _mh _mfp = ioe++check :: IOErrorType -> IOError -> Bool+check errorType ioe = ioeGetErrorType ioe == errorType++-- | An error indicating that an 'IO' operation failed because+-- one of its arguments already exists.+isAlreadyExistsError :: IOError -> Bool+isAlreadyExistsError = check AlreadyExists++-- | An error indicating that an 'IO' operation failed because+-- one of its arguments does not exist.+isDoesNotExistError :: IOError -> Bool+isDoesNotExistError  = check DoesNotExist++-- | An error indicating that an 'IO' operation failed because+-- one of its arguments is a single-use resource, which is already+-- being used (for example, opening the same file twice for writing+-- might give this error).+isAlreadyInUseError :: IOError -> Bool+isAlreadyInUseError  = check AlreadyInUse++-- | An error indicating that an 'IO' operation failed because+-- the device is full.+isFullError         :: IOError -> Bool+isFullError          = check Full++-- | An error indicating that an 'IO' operation failed because+-- the end of file has been reached.+isEOFError          :: IOError -> Bool+isEOFError           = check EOF++-- | An error indicating that an 'IO' operation failed because+-- the operation was not possible.+-- Any computation which returns an 'IO' result may fail with+-- 'isIllegalOperation'.  In some cases, an implementation will not be+-- able to distinguish between the possible error causes.  In this case+-- it should fail with 'isIllegalOperation'.+isIllegalOperation  :: IOError -> Bool+isIllegalOperation   = check IllegalOperation++-- | An error indicating that an 'IO' operation failed because+-- the user does not have sufficient operating system privilege+-- to perform that operation.+isPermissionError   :: IOError -> Bool+isPermissionError    = check Permission++-- | A programmer-defined error value constructed using 'userError'.+isUserError         :: IOError -> Bool+isUserError          = check User++deriving instance Eq IOErrorType+deriving instance Ord IOErrorType++alreadyExistsErrorType = AlreadyExists+doesNotExistErrorType = DoesNotExist+alreadyInUseErrorType = AlreadyInUse+fullErrorType = Full+eofErrorType = EOF+illegalOperationErrorType = IllegalOperation+permissionErrorType = Permission+userErrorType = User++instance Show IOError where+    showsPrec _ s = (ioeGetErrorString s ++)
+ lib/haskell-extras/System/IO/Pipe.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_JHC -fffi #-}+module System.IO.Pipe ( openPipe, openBinaryPipe ) where++import Jhc.Handle ( openPipe, openBinaryPipe )
+ lib/haskell-extras/System/Info.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_JHC -fm4 -fffi #-}+module System.Info(compilerName,compilerVersion,os,arch) where++import Foreign.C.String+import Foreign+import Data.Version ( Version(..) )++compilerName = "ajhc"++compilerVersion :: Version+compilerVersion = Version (splitup "__JHC_VERSION__") []+    where splitup s = case reads s of+                        [(v,s')] -> v : splitup s'+                        _ -> []++os = unsafePerformIO $ peekCAString =<< peek options_os+arch = unsafePerformIO $ peekCAString =<< peek options_arch+++foreign import ccall "&jhc_options_os"   options_os   :: Ptr CString+foreign import ccall "&jhc_options_arch" options_arch :: Ptr CString
+ lib/haskell-extras/System/Locale.hs view
@@ -0,0 +1,30 @@+module System.Locale where++data TimeLocale = TimeLocale {+        wDays  :: [(String, String)],   -- full and abbreviated week days+        months :: [(String, String)],   -- full and abbreviated months+        amPm   :: (String, String),     -- AM/PM symbols+        dateTimeFmt, dateFmt,           -- formatting strings+          timeFmt, time12Fmt :: String+        } deriving (Eq, Ord,Show)++defaultTimeLocale :: TimeLocale+defaultTimeLocale =  TimeLocale {+        wDays  = [("Sunday",   "Sun"),  ("Monday",    "Mon"),+                  ("Tuesday",  "Tue"),  ("Wednesday", "Wed"),+                  ("Thursday", "Thu"),  ("Friday",    "Fri"),+                  ("Saturday", "Sat")],++        months = [("January",   "Jan"), ("February",  "Feb"),+                  ("March",     "Mar"), ("April",     "Apr"),+                  ("May",       "May"), ("June",      "Jun"),+                  ("July",      "Jul"), ("August",    "Aug"),+                  ("September", "Sep"), ("October",   "Oct"),+                  ("November",  "Nov"), ("December",  "Dec")],++        amPm = ("AM", "PM"),+        dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",+        dateFmt = "%m/%d/%y",+        timeFmt = "%H:%M:%S",+        time12Fmt = "%I:%M:%S %p"+        }
+ lib/haskell-extras/System/Random.hs view
@@ -0,0 +1,259 @@+{-# OPTIONS_JHC -fffi #-}+{-+The June 1988 (v31 #6) issue of the Communications of the ACM has an+article by Pierre L'Ecuyer called, "Efficient and Portable Combined+Random Number Generators".  Here is the Portable Combined Generator of+L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.++Transliterator: Lennart Augustsson++sof 1/99 - code brought (kicking and screaming) into the new Random+world..++malcolm 2/00 - patched for nhc98+-}++module System.Random+	(+	  RandomGen(next, split, genRange)+	, StdGen+	, mkStdGen+	, Random ( random,   randomR,+		   randoms,  randomRs,+		   randomIO, randomRIO )+	, getStdRandom+	, getStdGen+	, setStdGen+	, newStdGen+	) where++import Data.Char ( isSpace, chr, ord )+import Foreign.Ptr+import Foreign.Storable+import Jhc.Class.Real+import Jhc.Num+import Numeric++class RandomGen g where+    next  :: g -> (Int, g)+    split :: g -> (g, g)+    genRange :: g -> (Int,Int)+    genRange g = (minBound,maxBound)++data StdGen = StdGen !Int !Int++instance RandomGen StdGen where+  next  = stdNext+  split = stdSplit+  genRange g = (minBound,maxBound)+  -- without this Hat+nhc98 do not work++instance Show StdGen where+  showsPrec p (StdGen s1 s2) =+     showsPrec p s1 .+     showChar ' ' .+     showsPrec p s2++instance Read StdGen where+  readsPrec _p = \ r ->+     case try_read r of+       r@[_] -> r+       _   -> [stdFromString r] -- because it shouldn't ever fail.+    where+      try_read r = do+         (s1, r1) <- readDec (dropWhile isSpace r)+	 (s2, r2) <- readDec (dropWhile isSpace r1)+	 return (StdGen s1 s2, r2)++{-+ If we cannot unravel the StdGen from a string, create+ one based on the string given.+-}+stdFromString         :: String -> (StdGen, String)+stdFromString s        = (mkStdGen num, rest)+	where (cs, rest) = splitAt 6 s+              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)++mkStdGen :: Int -> StdGen -- why not Integer ?+mkStdGen s+ | s < 0     = mkStdGen (-s)+ | otherwise = StdGen (s1+1) (s2+1)+      where+	(q, s1) = s `divMod` 2147483562+	s2      = q `mod` 2147483398++createStdGen :: Integer -> StdGen+createStdGen s+ | s < 0     = createStdGen (-s)+ | otherwise = StdGen (toInt (s1+1)) (toInt (s2+1))+      where+	(q, s1) = s `divMod` 2147483562+	s2      = q `mod` 2147483398++class Random a where+  -- Minimal complete definition: random and randomR+  random  :: RandomGen g => g -> (a, g)+  randomR :: RandomGen g => (a,a) -> g -> (a,g)+  randoms  :: RandomGen g => g -> [a]+  randomRs :: RandomGen g => (a,a) -> g -> [a]+  randomIO  :: IO a+  randomRIO :: (a,a) -> IO a++  randomRs ival g = x : randomRs ival g' where+    (x,g') = randomR ival g+  randomIO	   = getStdRandom random+  randoms  g      = (\(x,g') -> x : randoms g') (random g)+  randomRIO range  = getStdRandom (randomR range)++instance Random Int where+  randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g+  random g        = randomR (minBound,maxBound) g++instance Random Char where+  randomR (a,b) g =+      case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of+        (x,g) -> (chr x, g)+  random g	  = randomR (minBound,maxBound) g++instance Random Bool where+  randomR (a,b) g =+      case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of+        (x, g) -> (int2Bool (x::Int), g)+       where+         bool2Int False = (0::Int)+         bool2Int True  = 1++	 int2Bool 0	= False+	 int2Bool _	= True++  random g	  = randomR (minBound,maxBound) g++instance Random Integer where+  randomR ival g = randomIvalInteger ival g+  random g	 = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g++instance Random Double where+  randomR ival g = randomIvalDouble ival id g+  random g       = randomR (0::Double,1) g++-- hah, so you thought you were saving cycles by using Float?++instance Random Float where+  random g        = randomIvalDouble (0::Double,1) realToFrac g+  randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g++mkStdRNG :: Integer -> IO StdGen+mkStdRNG o = return (createStdGen o)+--mkStdRNG :: Integer -> IO StdGen+--mkStdRNG o = do+--    ct          <- getCPUTime+--    (TOD sec _) <- getClockTime+--    return (createStdGen (sec * 12345 + ct + o))++randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)+randomIvalInteger (l,h) rng+ | l > h     = randomIvalInteger (h,l) rng+ | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')+     where+       k = h - l + 1+       b = 2147483561+       --b = 2147  -- TODO Bad!+       n = iLogBase b k++       f 0 acc g = (acc, g)+       f n acc g =+          let+	   (x,g')   = next g+	  in+	  f (n-1) (fromInt x + acc * b) g'++randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)+randomIvalDouble (l,h) fromDouble rng+  | l > h     = randomIvalDouble (h,l) fromDouble rng+  | otherwise =+       case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of+         (x, rng') ->+	    let+	     scaled_x =+		fromDouble ((l+h)/2) ++                fromDouble ((h-l) / realToFrac intRange) *+		fromIntegral (x::Int)+	    in+	    (scaled_x, rng')++intRange :: Integer+intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)++iLogBase :: Integer -> Integer -> Integer+iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)++stdNext :: StdGen -> (Int, StdGen)+stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')+	where	z'   = if z < 1 then z + 2147483562 else z+		z    = s1'' - s2''++		k    = s1 `quot` 53668+		s1'  = 40014 * (s1 - k * 53668) - k * 12211+		s1'' = if s1' < 0 then s1' + 2147483563 else s1'++		k'   = s2 `quot` 52774+		s2'  = 40692 * (s2 - k' * 52774) - k' * 3791+		s2'' = if s2' < 0 then s2' + 2147483399 else s2'++stdSplit            :: StdGen -> (StdGen, StdGen)+stdSplit std@(StdGen s1 s2)+                     = (left, right)+                       where+                        -- no statistical foundation for this!+                        left    = StdGen new_s1 t2+                        right   = StdGen t1 new_s2++                        new_s1 | s1 == 2147483562 = 1+                               | otherwise        = s1 + 1++                        new_s2 | s2 == 1          = 2147483398+                               | otherwise        = s2 - 1++                        StdGen t1 t2 = snd (next std)+--  #else+-- stdSplit :: StdGen -> (StdGen, StdGen)+-- stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))+--  #endif++--ptr_a = unsafePerformIO $ malloc+--ptr_b = unsadePerformIO $ malloc++--setStdGen :: StdGen -> IO ()+--setStdGen sgen = writeIORef theStdGen sgen++--getStdGen :: IO StdGen+--getStdGen  = readIORef theStdGen++--theStdGen :: IORef StdGen+--theStdGen  = unsafePerformIO (newIORef (createStdGen 0))++setStdGen :: StdGen -> IO ()+getStdGen :: IO StdGen+setStdGen (StdGen a b) = do+    pokeElemOff c_stdrnd 0 a+    pokeElemOff c_stdrnd 1 b+getStdGen = do+    a <- peekElemOff c_stdrnd 0+    b <- peekElemOff c_stdrnd 1+    return $ StdGen a b++foreign import ccall "&jhc_stdrnd" c_stdrnd :: Ptr Int++newStdGen :: IO StdGen+newStdGen = do+  rng <- getStdGen+  let (a,b) = split rng+  setStdGen a+  return b++getStdRandom :: (StdGen -> (a,StdGen)) -> IO a+getStdRandom f = do+   rng		<- getStdGen+   let (v, new_rng) = f rng+   setStdGen new_rng+   return v
+ lib/haskell-extras/System/Time.hs view
@@ -0,0 +1,230 @@+{-# OPTIONS_JHC -fffi #-}+module System.Time (+    ClockTime(),+    Month(..),+    Day(..),+    CalendarTime(..),+    TimeDiff(..),+    getClockTime,+    addToClockTime,+    diffClockTimes,+    toCalendarTime,+    toUTCTime,+    toClockTime,+    calendarTimeToString,+    formatCalendarTime+    ) where++import Data.Char+import Data.Ix+import Foreign.C.Types+import Foreign.Ptr+import System.Locale+import System.IO.Unsafe++newtype ClockTime = TOD Integer+    deriving(Eq,Ord)++-- When a ClockTime is shown, it is converted to a CalendarTime in the current+-- timezone and then printed.  FIXME: This is arguably wrong, since we can't+-- get the current timezone without being in the IO monad.++instance Show ClockTime where+    showsPrec _ t = showString (calendarTimeToString+	  			 (unsafePerformIO (toCalendarTime t)))++data Month =  January   | February | March    | April+           |  May       | June     | July     | August+           |  September | October  | November | December+           deriving (Eq, Ord, Enum, Bounded, Read, Show)++instance Ix Month where+    range (x,y) = enumFromTo x y+    index (x,y) i+        | y < x || i < x || i > y = error "Time.Month.Ix: index out of range"+        | otherwise = fromEnum i - fromEnum x+    inRange (x,y) i = y >= x && (not $ i < x || i > y)+    rangeSize (x,y)+        | y < x = 0+        | otherwise = fromEnum y - fromEnum x++++data Day   =  Sunday | Monday  | Tuesday  | Wednesday | Thursday+           |  Friday | Saturday+           deriving (Eq, Ord, Enum, Bounded, Read, Show)++instance Ix Day where+    range (x,y) = enumFromTo x y+    index (x,y) i+        | y < x || i < x || i > y = error "Time.Day.Ix: index out of range"+        | otherwise = fromEnum i - fromEnum x+    inRange (x,y) i = y >= x && (not $ i < x || i > y)+    rangeSize (x,y)+        | y < x = 0+        | otherwise = fromEnum y - fromEnum x++data CalendarTime = CalendarTime {+    ctYear       :: !Int,+    ctMonth      :: !Month,+    ctDay, ctHour, ctMin, ctSec  :: !Int,+    ctPicosec    :: !Integer,+    ctWDay       :: !Day,+    ctYDay       :: !Int,+    ctTZName     :: String,+    ctTZ         :: !Int,+    ctIsDST      :: !Bool+    } deriving (Eq, Ord)++data TimeDiff = TimeDiff {+    tdYear, tdMonth, tdDay, tdHour, tdMin, tdSec :: !Int,+    tdPicosec      :: !Integer+    } deriving (Eq, Ord)+++-- Functions on times+getClockTime         :: IO ClockTime+getClockTime = do+    secs <- c_time nullPtr -- can't fail, according to POSIX+    return (TOD (ctimeToInteger secs))++foreign import primitive "U2U" ctimeToInteger :: CTime -> Integer+   -- -----------------------------------------------------------------------------+-- | converts an internal clock time to a local time, modified by the+-- timezone and daylight savings time settings in force at the time+-- of conversion.  Because of this dependence on the local environment,+-- 'toCalendarTime' is in the 'IO' monad.++toCalendarTime :: ClockTime -> IO CalendarTime+toCalendarTime =  toCalTime False++-- | converts an internal clock time into a 'CalendarTime' in standard+-- UTC format.++toUTCTime :: ClockTime -> CalendarTime+toUTCTime      =  unsafePerformIO . toCalTime True++toCalTime :: Bool -> ClockTime -> IO CalendarTime+toCalTime = error "toCalTime"++toClockTime          :: CalendarTime -> ClockTime+toClockTime = error "toClockTime"++calendarTimeToString    :: CalendarTime -> String+calendarTimeToString    =  formatCalendarTime defaultTimeLocale "%c"++-- -----------------------------------------------------------------------------+-- | @'addToClockTime' d t@ adds a time difference @d@ and a+-- clock time @t@ to yield a new clock time.  The difference @d@+-- may be either positive or negative.++addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime+addToClockTime (TimeDiff year mon day hour min sec psec)+	       (TOD c_sec) =+	let+	  sec_diff = toInteger sec ++                     60 * toInteger min ++                     3600 * toInteger hour ++                     24 * 3600 * toInteger day+	  --cal      = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))+	  cal      = toUTCTime (TOD (c_sec + sec_diff))+                                                       -- FIXME! ^^^^+          new_mon  = fromEnum (ctMonth cal) + r_mon+	  month' = fst tmp+	  yr_diff = snd tmp+          tmp+	    | new_mon < 0  = (toEnum (12 + new_mon), (-1))+	    | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)+	    | otherwise    = (toEnum new_mon, 0)++	  (r_yr, r_mon) = mon `quotRem` 12++          year' = ctYear cal + year + r_yr + yr_diff+	in+	toClockTime cal{ctMonth=month', ctYear=year'}++-- | @'diffClockTimes' t1 t2@ returns the difference between two clock+-- times @t1@ and @t2@ as a 'TimeDiff'.++diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff+-- diffClockTimes is meant to be the dual to `addToClockTime'.+-- If you want to have the TimeDiff properly splitted, use+-- `normalizeTimeDiff' on this function's result+--+-- CAVEAT: see comment of normalizeTimeDiff+diffClockTimes (TOD sa) (TOD sb) =+    noTimeDiff{ tdSec  = fromIntegral (sa - sb) }++noTimeDiff :: TimeDiff+noTimeDiff = TimeDiff 0 0 0 0 0 0 0+++formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String+formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec+                                           wday yday tzname _ _) =+        doFmt fmt+  where doFmt ('%':c:cs) = decode c ++ doFmt cs+        doFmt (c:cs) = c : doFmt cs+        doFmt "" = ""++        to12 :: Int -> Int+        to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'++        decode 'A' = fst (wDays l  !! fromEnum wday)+        decode 'a' = snd (wDays l  !! fromEnum wday)+        decode 'B' = fst (months l !! fromEnum mon)+        decode 'b' = snd (months l !! fromEnum mon)+        decode 'h' = snd (months l !! fromEnum mon)+        decode 'C' = show2 (year `quot` 100)+        decode 'c' = doFmt (dateTimeFmt l)+        decode 'D' = doFmt "%m/%d/%y"+        decode 'd' = show2 day+        decode 'e' = show2' day+        decode 'H' = show2 hour+        decode 'I' = show2 (to12 hour)+        decode 'j' = show3 yday+        decode 'k' = show2' hour+        decode 'l' = show2' (to12 hour)+        decode 'M' = show2 min+        decode 'm' = show2 (fromEnum mon+1)+        decode 'n' = "\n"+        decode 'p' = (if hour < 12 then fst else snd) (amPm l)+        decode 'R' = doFmt "%H:%M"+        decode 'r' = doFmt (time12Fmt l)+        decode 'T' = doFmt "%H:%M:%S"+        decode 't' = "\t"+        decode 'S' = show2 sec+--        decode 's' = ...                -- Implementation-dependent+        decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)+        decode 'u' = show (let n = fromEnum wday in+                           if n == 0 then 7 else n)+        decode 'V' =+            let (week, days) =+                   (yday + 7 - if fromEnum wday > 0 then+                               fromEnum wday - 1 else 6) `divMod` 7+            in  show2 (if days >= 4 then+                          week+1+                       else if week == 0 then 53 else week)++        decode 'W' =+            show2 ((yday + 7 - if fromEnum wday > 0 then+                               fromEnum wday - 1 else 6) `div` 7)+        decode 'w' = show (fromEnum wday)+        decode 'X' = doFmt (timeFmt l)+        decode 'x' = doFmt (dateFmt l)+        decode 'Y' = show year+        decode 'y' = show2 (year `rem` 100)+        decode 'Z' = tzname+        decode '%' = "%"+        decode c   = [c]++show2, show2', show3 :: Int -> String+show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]++show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x++show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)+++foreign import unsafe ccall "time.h time" c_time :: Ptr CTime -> IO CTime+
+ lib/haskell-extras/Text/Printf.hs view
@@ -0,0 +1,275 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Printf+-- Copyright   :  (c) Lennart Augustsson, 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  lennart@augustsson.net+-- Stability   :  provisional+-- Portability :  portable+--+-- A C printf like formatter.+--+-----------------------------------------------------------------------------++module Text.Printf(+   printf, hPrintf,+   PrintfType, HPrintfType, PrintfArg, IsChar+) where++import Data.Char+import Numeric(showEFloat, showFFloat, showGFloat)+import System.IO++-------------------++-- | Format a variable number of arguments with the C-style formatting string.+-- The return value is either 'String' or @('IO' a)@.+--+-- The format string consists of ordinary characters and /conversion+-- specifications/, which specify how to format one of the arguments+-- to printf in the output string.  A conversion specification begins with the+-- character @%@, followed by one or more of the following flags:+--+-- >    -      left adjust (default is right adjust)+-- >    0      pad with zeroes rather than spaces+--+-- followed optionally by a field width:+--+-- >    num    field width+-- >    *      as num, but taken from argument list+--+-- followed optionally by a precision:+--+-- >    .num   precision (number of decimal places)+--+-- and finally, a format character:+--+-- >    c      character               Char, Int, Integer+-- >    d      decimal                 Char, Int, Integer+-- >    o      octal                   Char, Int, Integer+-- >    x      hexadecimal             Char, Int, Integer+-- >    u      unsigned decimal        Char, Int, Integer+-- >    f      floating point          Float, Double+-- >    g      general format float    Float, Double+-- >    e      exponent format float   Float, Double+-- >    s      string                  String+--+-- Mismatch between the argument types and the format string will cause+-- an exception to be thrown at runtime.+--+-- Examples:+--+-- >   > printf "%d\n" (23::Int)+-- >   23+-- >   > printf "%s %s\n" "Hello" "World"+-- >   Hello World+-- >   > printf "%.2f\n" pi+-- >   3.14+--+printf :: (PrintfType r) => String -> r+printf fmt = spr fmt []++-- | Similar to 'printf', except that output is via the specified+-- 'Handle'.  The return type is restricted to @('IO' a)@.+hPrintf :: (HPrintfType r) => Handle -> String -> r+hPrintf hdl fmt = hspr hdl fmt []++-- |The 'PrintfType' class provides the variable argument magic for+-- 'printf'.  Its implementation is intentionally not visible from+-- this module. If you attempt to pass an argument of a type which+-- is not an instance of this class to 'printf' or 'hPrintf', then+-- the compiler will report it as a missing instance of 'PrintfArg'.+class PrintfType t where+    spr :: String -> [UPrintf] -> t++-- | The 'HPrintfType' class provides the variable argument magic for+-- 'hPrintf'.  Its implementation is intentionally not visible from+-- this module.+class HPrintfType t where+    hspr :: Handle -> String -> [UPrintf] -> t++{- not allowed in Haskell 98+instance PrintfType String where+    spr fmt args = uprintf fmt (reverse args)+-}+instance (IsChar c) => PrintfType [c] where+    spr fmt args = map fromChar (uprintf fmt (reverse args))++instance PrintfType (IO a) where+    spr fmt args = do+	putStr (uprintf fmt (reverse args))+	return undefined++instance HPrintfType (IO a) where+    hspr hdl fmt args = do+	hPutStr hdl (uprintf fmt (reverse args))+	return undefined++instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where+    spr fmt args = \ a -> spr fmt (toUPrintf a : args)++instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where+    hspr hdl fmt args = \ a -> hspr hdl fmt (toUPrintf a : args)++class PrintfArg a where+    toUPrintf :: a -> UPrintf++instance PrintfArg Char where+    toUPrintf c = UChar c++{- not allowed in Haskell 98+instance PrintfArg String where+    toUPrintf s = UString s+-}+instance (IsChar c) => PrintfArg [c] where+    toUPrintf s = UString (map toChar s)++instance PrintfArg Int where+    toUPrintf i = UInt i++instance PrintfArg Integer where+    toUPrintf i = UInteger i++instance PrintfArg Float where+    toUPrintf f = UFloat f++instance PrintfArg Double where+    toUPrintf d = UDouble d++class IsChar c where+    toChar :: c -> Char+    fromChar :: Char -> c++instance IsChar Char where+    toChar c = c+    fromChar c = c++-------------------++data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double++uprintf :: String -> [UPrintf] -> String+uprintf ""       []       = ""+uprintf ""       (_:_)    = fmterr+uprintf ('%':'%':cs) us   = '%':uprintf cs us+uprintf ('%':_)  []       = argerr+uprintf ('%':cs) us@(_:_) = fmt cs us+uprintf (c:cs)   us       = c:uprintf cs us++fmt :: String -> [UPrintf] -> String+fmt cs us =+	let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us+	    adjust (pre, str) =+		let lstr = length str+		    lpre = length pre+		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""+		in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str+        in+	case cs' of+	[]     -> fmterr+	c:cs'' ->+	    case us' of+	    []     -> argerr+	    u:us'' ->+		(case c of+		'c' -> adjust ("", [toEnum (toint u)])+		'd' -> adjust (fmti u)+		'x' -> adjust ("", fmtu 16 u)+		'o' -> adjust ("", fmtu 8  u)+		'u' -> adjust ("", fmtu 10 u)+		'e' -> adjust (dfmt' c prec u)+		'f' -> adjust (dfmt' c prec u)+		'g' -> adjust (dfmt' c prec u)+		's' -> adjust ("", tostr u)+		c   -> perror ("bad formatting char " ++ [c])+		 ) ++ uprintf cs'' us''++fmti (UInt i)     = if i < 0 then+			if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))+		    else+			("", itos i)+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)+fmti (UChar c)    = fmti (UInt (fromEnum c))+fmti u		  = baderr++fmtu b (UInt i)     = if i < 0 then+			  if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))+		      else+			  itosb b (toInteger i)+fmtu b (UInteger i) = itosb b i+fmtu b (UChar c)    = itosb b (toInteger (fromEnum c))+fmtu b u            = baderr++maxi :: Integer+maxi = (toInteger (maxBound::Int) + 1) * 2++toint (UInt i)     = i+toint (UInteger i) = toInt i+toint (UChar c)    = fromEnum c+toint u		   = baderr++tostr (UString s) = s+tostr u		  = baderr++itos n =+	if n < 10 then+	    [toEnum (fromEnum '0' + toInt n)]+	else+	    let (q, r) = quotRem n 10 in+	    itos q ++ [toEnum (fromEnum '0' + toInt r)]++itosb :: Integer -> Integer -> String+itosb b n =+	if n < b then+	    [intToDigit $ fromInteger n]+	else+	    let (q, r) = quotRem n b in+	    itosb b q ++ [intToDigit $ fromInteger r]++stoi :: Int -> String -> (Int, String)+stoi a (c:cs) | isDigit c = stoi (a*10 + fromEnum c - fromEnum '0') cs+stoi a cs                 = (a, cs)++getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])+getSpecs l z ('-':cs) us = getSpecs True z cs us+getSpecs l z ('0':cs) us = getSpecs l True cs us+getSpecs l z ('*':cs) us =+        case us of+        [] -> argerr+        nu : us' ->+	    let n = toint nu+		(p, cs'', us'') =+		    case cs of+                    '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }+		    '.':r     -> let (n, cs') = stoi 0 r in (n, cs', us')+		    _         -> (-1, cs, us')+	    in  (n, p, l, z, cs'', us'')+getSpecs l z ('.':cs) us =+	let (p, cs') = stoi 0 cs+	in  (0, p, l, z, cs', us)+getSpecs l z cs@(c:_) us | isDigit c =+	let (n, cs') = stoi 0 cs+	    (p, cs'') = case cs' of+			'.':r -> stoi 0 r+			_     -> (-1, cs')+	in  (n, p, l, z, cs'', us)+getSpecs l z cs       us = (0, -1, l, z, cs, us)++dfmt' c p (UDouble d) = dfmt c p d+dfmt' c p (UFloat f)  = dfmt c p f+dfmt' c p u           = baderr++dfmt c p d =+	case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat)+               (if p < 0 then Nothing else Just p) d "" of+	'-':cs -> ("-", cs)+	cs     -> ("" , cs)++perror s = error ("Printf.printf: "++s)+fmterr = perror "formatting string ended prematurely"+argerr = perror "argument list ended prematurely"+baderr = perror "bad argument"++toInt :: (Integral a) => a -> Int+toInt x = fromInteger (toInteger x)
+ lib/haskell-extras/Text/Show/Functions.hs view
@@ -0,0 +1,5 @@+module Text.Show.Functions where+++instance Show (a -> b) where+    showsPrec _ _ = showString "<function>"
+ lib/haskell-extras/Typeable.hs view
@@ -0,0 +1,15 @@+module Typeable where++class Typeable a where+    typeOf :: a -> String+    typeOf _ = "Unknown"++instance Typeable Char where+    typeOf _ = "Char"++instance Typeable Bool where+    typeOf _ = "Bool"++instance Typeable a => Typeable [a] where+    typeOf x = "[" ++ typeOf (head x) ++ "]"+
+ lib/haskell-extras/Unsafe/Coerce.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Unsafe.Coerce(unsafeCoerce) where++foreign import primitive unsafeCoerce :: a -> b
+ lib/haskell-extras/haskell-extras.yaml.m4 view
@@ -0,0 +1,65 @@+Name: haskell-extras+Version: __JHC_VERSION__+Hs-Source-Dir: .+Extensions: ForeignFunctionInterface+build-depends: jhc+Options: [ --noauto ]+Exposed-Modules:+        - Control.Exception+        - Control.Monad+        - Data.Array+        - Data.Char+        - Data.Complex+        - Data.List+        - Data.Word+        - Data.Monoid+        - Data.Bits+        - Data.Int+        - Data.Functor+        - Data.IORef+        - Data.Ix+        - Data.Maybe+        - Data.Ratio+        - Data.Unicode+        - Debug.Trace+        - Foreign+        - Foreign.C+        - Foreign.C.Types+        - Foreign.C.String+        - Foreign.C.Error+        - Foreign.ForeignPtr+        - Foreign.Marshal+        - Foreign.Marshal.Alloc+        - Foreign.Marshal.Array+        - Foreign.Marshal.Error+        - Foreign.Marshal.Pool+        - Foreign.Marshal.Utils+        - Foreign.Ptr+        - Foreign.StablePtr+        - Foreign.Storable+        - Data.Array.IO+        - Data.Array.Unboxed+        - Numeric+        - Prelude+        - System.Console.GetOpt+        - System.CPUTime+        - System.Directory+        - System.Info+        - System.IO+        - System.IO.Error+        - System.IO.Unsafe+        - System.IO.Binary+        - System.IO.Pipe+        - System.Locale+        - System.Random+        - System.Time+        - System.Environment+        - System.Exit+        - System.Cmd+        - Control.Monad.Fix+        - Data.Function+        - Text.Show.Functions+        - Data.Typeable+        - Data.Version+        - Control.Monad.Instances+        - Text.Printf
+ lib/haskell2010/haskell2010.yaml.m4 view
@@ -0,0 +1,39 @@+Name: haskell2010+Version: __JHC_VERSION__+Extensions: [ ForeignFunctionInterface, NoImplicitPrelude,+              UnboxedTuples, UnboxedValues ]+Hs-Source-Dir: .+build-depends: [ jhc, haskell-extras ]+Options: [ --noauto ]+Exposed-Modules:+        - Control.Monad+        - Data.Array+        - Data.Bits+        - Data.Char+        - Data.Complex+        - Data.Int+        - Data.Ix+        - Data.List+        - Data.Maybe+        - Data.Ratio+        - Data.Word+        - Foreign+        - Foreign.C+        - Foreign.C.Error+        - Foreign.C.String+        - Foreign.C.Types+        - Foreign.ForeignPtr+        - Foreign.Marshal+        - Foreign.Marshal.Alloc+        - Foreign.Marshal.Array+        - Foreign.Marshal.Error+        - Foreign.Marshal.Utils+        - Foreign.Ptr+        - Foreign.StablePtr+        - Foreign.Storable+        - Numeric+        - Prelude+        - System.Environment+        - System.Exit+        - System.IO+        - System.IO.Error
+ lib/haskell98/Array.hs view
@@ -0,0 +1,8 @@+module Array (+    module Ix,  -- export all of Ix for convenience+    Array, array, listArray, (!), bounds, indices, elems, assocs,+    accumArray, (//), accum, ixmap+  ) where++import Ix+import Data.Array
+ lib/haskell98/CPUTime.hs view
@@ -0,0 +1,5 @@+module CPUTime (+    getCPUTime, cpuTimePrecision+  ) where++import System.CPUTime
+ lib/haskell98/Char.hs view
@@ -0,0 +1,13 @@+module Char (+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,+    digitToInt, intToDigit,+    toUpper, toLower,+    ord, chr,+    readLitChar, showLitChar, lexLitChar,++-- ...and what the Prelude exports+    Char, String+  ) where++import Data.Char
+ lib/haskell98/Complex.hs view
@@ -0,0 +1,6 @@+module Complex (+    Complex((:+)), realPart, imagPart, conjugate,+    mkPolar, cis, polar, magnitude, phase+  ) where++import Data.Complex
+ lib/haskell98/Directory.hs view
@@ -0,0 +1,11 @@+module Directory (+    Permissions( Permissions, readable, writable, executable, searchable ),+    createDirectory, removeDirectory, removeFile,+    renameDirectory, renameFile, getDirectoryContents,+    getCurrentDirectory, setCurrentDirectory,+    doesFileExist, doesDirectoryExist,+    getPermissions, setPermissions,+    getModificationTime+  ) where++import System.Directory
+ lib/haskell98/IO.hs view
@@ -0,0 +1,58 @@+module IO (+    Handle, HandlePosn,+    IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),+    BufferMode(NoBuffering,LineBuffering,BlockBuffering),+    SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),+    stdin, stdout, stderr,+    openFile, hClose, hFileSize, hIsEOF, isEOF,+    hSetBuffering, hGetBuffering, hFlush,+    hGetPosn, hSetPosn, hSeek,+    hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents,+    hPutChar, hPutStr, hPutStrLn, hPrint,+    hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable,+    isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,+    isFullError, isEOFError,+    isIllegalOperation, isPermissionError, isUserError,+    ioeGetErrorString, ioeGetHandle, ioeGetFileName,+    try, bracket, bracket_,++    -- ...and what the Prelude exports+    IO, FilePath, IOError, ioError, userError, catch, interact,+    putChar, putStr, putStrLn, print, getChar, getLine, getContents,+    readFile, writeFile, appendFile, readIO, readLn+  ) where++import System.IO+import System.IO.Error++-- | The 'bracket' function captures a common allocate, compute, deallocate+-- idiom in which the deallocation step must occur even in the case of an+-- error during computation. This is similar to try-catch-finally in Java.+--+-- This version handles only IO errors, as defined by Haskell 98.+-- The version of @bracket@ in "Control.Exception" handles all exceptions,+-- and should be used instead.++bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+bracket before after m = do+        x  <- before+        rs <- try (m x)+        _ <- after x+        case rs of+           Right r -> return r+           Left  e -> ioError e++-- | A variant of 'bracket' where the middle computation doesn't want @x@.+--+-- This version handles only IO errors, as defined by Haskell 98.+-- The version of @bracket_@ in "Control.Exception" handles all exceptions,+-- and should be used instead.++bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c+bracket_ before after m = do+         x  <- before+         rs <- try m+         _ <- after x+         case rs of+            Right r -> return r+            Left  e -> ioError e
+ lib/haskell98/Ix.hs view
@@ -0,0 +1,5 @@+module Ix (+    Ix(range, index, inRange), rangeSize+  ) where++import Data.Ix
+ lib/haskell98/LICENSE view
@@ -0,0 +1,32 @@+Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++  Copyright (c) 2002 Simon Peyton Jones++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Language.++-----------------------------------------------------------------------------++Code derived from the document "The Haskell 98 Foreign Function+Interface, An Addendum to the Haskell 98 Report" is distributed under+the following license:++  Copyright (c) 2002 Manuel M. T. Chakravarty++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Foreign Function Interface.++-----------------++This code has been modified by John Meacham for distribution with jhc
+ lib/haskell98/List.hs view
@@ -0,0 +1,29 @@+module List (+    elemIndex, elemIndices,+    find, findIndex, findIndices,+    nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,+    union, unionBy, intersect, intersectBy,+    intersperse, transpose, partition, group, groupBy,+    inits, tails, isPrefixOf, isSuffixOf,+    mapAccumL, mapAccumR,+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,+    genericLength, genericTake, genericDrop,+    genericSplitAt, genericIndex, genericReplicate,+    zip4, zip5, zip6, zip7,+    zipWith4, zipWith5, zipWith6, zipWith7,+    unzip4, unzip5, unzip6, unzip7, unfoldr,++    -- ...and what the Prelude exports+    -- []((:), []), -- This is built-in syntax+    map, (++), concat, filter,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3+  ) where++import Data.List hiding (foldl')
+ lib/haskell98/Locale.hs view
@@ -0,0 +1,10 @@+module Locale (+    TimeLocale(..), defaultTimeLocale+  ) where++import System.Locale (+	-- just the bits that are specified by Haskell 98+	TimeLocale(TimeLocale,wDays,months,amPm,dateTimeFmt,+		   dateFmt,timeFmt,time12Fmt),+        defaultTimeLocale+    )
+ lib/haskell98/Maybe.hs view
@@ -0,0 +1,11 @@+module Maybe (+    isJust, isNothing,+    fromJust, fromMaybe, listToMaybe, maybeToList,+    catMaybes, mapMaybe,++    -- ...and what the Prelude exports+    Maybe(Nothing, Just),+    maybe+  ) where++import Data.Maybe
+ lib/haskell98/Monad.hs view
@@ -0,0 +1,14 @@+module Monad (+    MonadPlus(mzero, mplus),+    join, guard, when, unless, ap,+    msum,+    filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM,+    liftM, liftM2, liftM3, liftM4, liftM5,++    -- ...and what the Prelude exports+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<),+  ) where++import Control.Monad
+ lib/haskell98/Random.hs view
@@ -0,0 +1,8 @@+module Random (+   RandomGen(next, split, genRange),+   StdGen, mkStdGen,+   Random( random,   randomR, randoms,  randomRs, randomIO, randomRIO ),+   getStdRandom, getStdGen, setStdGen, newStdGen+  ) where++import System.Random
+ lib/haskell98/Ratio.hs view
@@ -0,0 +1,5 @@+module Ratio (+    Ratio, Rational, (%), numerator, denominator, approxRational+  ) where++import Data.Ratio
+ lib/haskell98/System.hs view
@@ -0,0 +1,8 @@+module System (+    ExitCode(ExitSuccess,ExitFailure),+    getArgs, getProgName, getEnv, system, exitWith, exitFailure+  ) where++import System.Exit+import System.Environment+import System.Cmd
+ lib/haskell98/Time.hs view
@@ -0,0 +1,15 @@+module Time (+    ClockTime,+    Month(January,February,March,April,May,June,+          July,August,September,October,November,December),+    Day(Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday),+    CalendarTime(CalendarTime, ctYear, ctMonth, ctDay, ctHour, ctMin,+    		 ctSec, ctPicosec, ctWDay, ctYDay, ctTZName, ctTZ, ctIsDST),+    TimeDiff(TimeDiff, tdYear, tdMonth, tdDay, tdHour,+ 	     tdMin, tdSec, tdPicosec),+    getClockTime, addToClockTime, diffClockTimes,+    toCalendarTime, toUTCTime, toClockTime,+    calendarTimeToString, formatCalendarTime+  ) where++import System.Time
+ lib/haskell98/haskell98.yaml view
@@ -0,0 +1,6 @@+name: 	haskell98+version: 1.0+options:        --noauto+build-depends: [ haskell2010, haskell-extras ]+hs-source-dir: .+exposed-modules: [ Prelude, Numeric, Array, CPUTime, Char, Complex, Directory, IO, Ix, List, Locale, Maybe, Monad, Random, Ratio, System, Time ]
+ lib/haskell98/prologue.txt view
@@ -0,0 +1,9 @@+This package provides compatibility with the modules of Haskell 98 and+the FFI addendum, by means of wrappers around modules from the @base@ package+(which in many cases have additional features).+However @Prelude@, @Numeric@ and @Foreign@ are provided directly+by the @base@ package.+The modules of this package are documented in the /Revised Haskell 98 Report/,+at <http://www.haskell.org/onlinereport/>,+and the /Haskell 98 Foreign Function Interface/ addendum,+at <http://www.cse.unsw.edu.au/~chak/haskell/ffi/>.
+ lib/jhc-prim/Jhc/Prim/Array.hs view
@@ -0,0 +1,14 @@+module Jhc.Prim.Array where++import Jhc.Prim.IO+import Jhc.Prim.Bits++data MutArray_ :: * -> #+newtype Array_ m = Array_ (MutArray_ m)++foreign import primitive newArray__      :: Word_ -> a -> UST s (MutArray_ a)+foreign import primitive newBlankArray__ :: Word_ -> UST s (MutArray_ a)+foreign import primitive copyArray__     :: Word_ -> Word_ -> Word_ -> MutArray_ a -> MutArray_ a -> UST_ s+foreign import primitive readArray__     :: MutArray_ a -> Word_ -> UST s a+foreign import primitive writeArray__    :: MutArray_ a -> Word_ -> a -> UST_ s+foreign import primitive indexArray__    :: Array_ a -> Word_ -> (# a #)
+ lib/jhc-prim/Jhc/Prim/Bits.hs view
@@ -0,0 +1,40 @@+module Jhc.Prim.Bits where++-- this declares the built in unboxed types.+-- no code is brought in by this module, it just+-- brings the names into scope, so it is okay to+-- have platform specific definitions here.++-- The CTYPE of the raw types is declared in src/DataConstructors.hs+data Bits1_ :: #++data Bits8_   :: #+data Bits16_  :: #+data Bits32_  :: #+data Bits64_  :: #+data Bits128_ :: #+data BitsPtr_ :: #+data BitsMax_ :: #++data Float16_  :: #+data Float32_  :: #+data Float64_  :: #+data Float80_  :: #+data Float128_ :: #+data FloatMax_ :: #++data Complex_ :: # -> #++-- these newtypes exist to modify the+-- calling convention and provide hints as+-- to the use of the types.+newtype {-# CTYPE "HsPtr" #-}    Addr_    = Addr_ BitsPtr_+newtype {-# CTYPE "HsFunPtr" #-} FunAddr_ = FunAddr_ BitsPtr_+newtype {-# CTYPE "bool" #-}     Bool_    = Bool_ Bits16_+newtype {-# CTYPE "wchar_t" #-}  Char_    = Char_ Bits32_++-- type aliases to help document whether signed or unsigned+-- uses are intended, they have no effect other than helping+-- convey intent to someone reading the code.+type Word_ = Bits32_+type Int_  = Bits32_
+ lib/jhc-prim/Jhc/Prim/IO.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE UnboxedTuples #-}+module Jhc.Prim.IO where++data State_ :: * -> #+data RealWorld :: *++type World__ = State_ RealWorld++-- Aliases for common State_ related types. Useful in foreign imports.+type UST s a = State_ s -> (# State_ s, a #)+type UST_ s = State_ s -> State_ s+-- Aliases specialized for the world.+type UIO a = UST RealWorld a+type UIO_ = UST_ RealWorld++newtype ST s a = ST (UST s a)+newtype IO a = IO (ST RealWorld a)+newtype ACIO a = ACIO (IO a)++-- Note the implicit unsafeCoerce__ here!+-- We currently don't allow exeptions in general ST monads as a design choice.+foreign import primitive catch__ :: UIO a -> (e -> UIO a) -> UIO a+foreign import primitive raiseIO__ :: e -> UIO_
+ lib/jhc-prim/Jhc/Prim/Prim.hs view
@@ -0,0 +1,25 @@+-- This module is always included behind the scenes when compiling.+-- It will not bring any code into the system, but brings several+-- names and type definitions into scope that the compiler expects+-- to exist.+module Jhc.Prim.Prim where++import Jhc.Prim.Bits+import Jhc.Prim.IO++data (->) :: ?? -> ? -> *++infixr 5  :+data [] a =  a : ([] a) | []+data {-# CTYPE "HsBool" #-} Bool = False | True+data Ordering =  LT | EQ | GT++data () = ()+data (,) a b = (,) a b+data (,,) a b c = (,,) a b c+data (,,,) a b c d = (,,,) a b c d+data (,,,,) a b c d e = (,,,,) a b c d e+data (,,,,,) a b c d e f = (,,,,,) a b c d e f+data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g+data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h+data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i
+ lib/jhc-prim/Jhc/Prim/Rts.hs view
@@ -0,0 +1,19 @@+-- allowing introspection into the rts+module Jhc.Prim.Rts where++import Jhc.Prim.Bits++-- A Bang_ is always in WHNF. The mnemonic is 'Bang_ Char ~ !Char'+-- Bang_ is also an FFI-able type that turns into a raw haskell object pointer.+data {-# CTYPE "wptr_t" #-} Bang_ a :: #++-- safe+foreign import primitive toBang_     :: a -> Bang_ a+foreign import primitive fromBang_   :: Bang_ a -> a+-- unwise+foreign import primitive isWHNF      :: a -> Bool_+foreign import primitive isInHeap    :: Bang_ a -> Bool_+foreign import primitive bangPtr     :: Bang_ a -> Addr_+foreign import primitive bangToRaw   :: Bang_ a -> BitsPtr_+-- unsafe+foreign import primitive bangFromRaw :: BitsPtr_ -> Bang_ a
+ lib/jhc-prim/Jhc/Prim/Wrapper.hs view
@@ -0,0 +1,11 @@+module Jhc.Prim.Wrapper where++import Jhc.Prim.IO++-- | when no exception wrapper is wanted+runNoWrapper :: IO a -> World__ -> World__+runNoWrapper (IO (ST run)) w = case run w of (# w, _ #) -> w++-- | this is wrapped around arbitrary expressions and just+-- evaluates them to whnf+foreign import primitive "seq" runRaw :: a -> World__ -> World__
+ lib/jhc-prim/jhc-prim.yaml view
@@ -0,0 +1,12 @@+Name: jhc-prim+Version: 1.0+Extensions: [ ForeignFunctionInterface, NoImplicitPrelude, UnboxedTuples, UnboxedValues ]+Options: --noauto+Hs-Source-Dir: .+Exposed-Modules:+        - Jhc.Prim.Array+        - Jhc.Prim.Bits+        - Jhc.Prim.IO+        - Jhc.Prim.Prim+        - Jhc.Prim.Rts+        - Jhc.Prim.Wrapper
+ lib/jhc/Data/Ratio.hs view
@@ -0,0 +1,117 @@+-- Standard functions on rational numbers+module  Data.Ratio (+    Ratio, Rational, (%), numerator, denominator, approxRational ) where++import Jhc.Basics+import Jhc.Float+import Jhc.IO+import Jhc.Num+import Jhc.Numeric+import Jhc.Order+import Prelude.Float()+import Prelude.Text+import Jhc.Class.Real++infixl 7  %++ratPrec = 7 :: Int++(%)                     :: (Integral a) => a -> a -> Ratio a+approxRational          :: (RealFrac a) => a -> a -> Rational++x % y                   =  reduce (x * signum y) (abs y)++-- "reduce" is a subsidiary function used only in this module.+-- It normalises a ratio by dividing both numerator+-- and denominator by their greatest common divisor.+--+-- E.g., 12 `reduce` 8    ==  3 :%   2+--       12 `reduce` (-8) ==  3 :% (-2)++reduce _ 0              =  error "Ratio.% : zero denominator"+reduce x y              =  (x `quot` d) :% (y `quot` d)+                           where d = gcd x y++instance  (Integral a)  => Eq (Ratio a)  where+    (x:%y) == (x':%y')  =  x == x' && y == y'++instance  (Integral a)  => Ord (Ratio a)  where+    (x:%y) <= (x':%y')  =  x * y' <= x' * y+    (x:%y) <  (x':%y')  =  x * y' <  x' * y++--negateRatio (x:%y)       =  (-x) :% y+--(x:%y) `plusRatio` (x':%y')   =  reduce ((x*y') + (x'*y)) (y*y')+--absRatio (x:%y)          =  abs x :% y++instance  (Integral a)  => Num (Ratio a)  where+    --(+) = plusRatio+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')+    --negate x {-(x:%y)-}   =  negateRatio x -- (-x) :% y+    negate (x:%y)       =  (-x) :% y+    --abs (x:%y)        =  abs x :% y+    abs (x:%y)          =  abs x :% y+    signum (x:%y)       =  signum x :% 1+    fromInteger x       =  fromInteger x :% 1+    fromInt     x       =  fromInt x :% 1++instance  (Integral a)  => Real (Ratio a)  where+    toRational (x:%y)   =  toInteger x :% toInteger y++    toDouble  x         = rationalToDouble (toRational x)++instance  (Integral a)  => Fractional (Ratio a)  where+    (x:%y) / (x':%y')   =  (x*y') % (y*x')+    recip (x:%y)        =  y % x+    fromRational (x:%y) =  fromInteger x :% fromInteger y+    fromDouble   x      = fromRational (doubleToRational x)++instance  (Integral a)  => RealFrac (Ratio a)  where+    properFraction (x:%y) = (fromIntegral q, r:%y)+                            where (q,r) = quotRem x y++{-+instance  (Integral a)  => Enum (Ratio a)  where+    succ x           =  x+1+    pred x           =  x-1+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate	-- May overflow+--    enumFrom         =  numericEnumFrom		-- These numericEnumXXX functions+--    enumFromThen     =  numericEnumFromThen	-- are as defined in Prelude.hs+--    enumFromTo       =  numericEnumFromTo	-- but not exported from it!+--    enumFromThenTo   =  numericEnumFromThenTo+-}++instance  (Read a, Integral a)  => Read (Ratio a)  where+    readsPrec p  =  readParen (p > ratPrec)+                              (\r -> [(reduce (x * signum y) (abs y),u) | (x,s)   <- readsPrec (ratPrec+1) r,+                                                ("%",t) <- lex s,+                                                (y,u)   <- readsPrec (ratPrec+1) t ])++instance  (Integral a)  => Show (Ratio a)  where+    showsPrec p (x:%y)  =  showParen (p > ratPrec)+                               (showsPrec (ratPrec+1) x .+			        showString " % " .+				showsPrec (ratPrec+1) y)++approxRational x eps    =  simplest (x-eps) (x+eps)+        where simplest x y | y < x      =  simplest y x+                           | x == y     =  xr+                           | x > 0      =  simplest' n d n' d'+                           | y < 0      =  - simplest' (-n') d' (-n) d+                           | otherwise  =  0 :% 1+                                        where xr@(n:%d) = toRational x+                                              (n':%d')  = toRational y++              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+                        | r == 0     =  q :% 1+                        | q /= q'    =  (q+1) :% 1+                        | otherwise  =  (q*n''+d'') :% n''+                                     where (q,r)      =  quotRem n d+                                           (q',r')    =  quotRem n' d'+                                           (n'':%d'') =  simplest' d' r' d r++doubleToRational :: Double -> Rational+doubleToRational x  =  (m:%1)*(b:%1)^^n where+    (m,n) = decodeFloat x+    b     = floatRadix  x
+ lib/jhc/Foreign/C/Error.hs view
@@ -0,0 +1,535 @@+{-# OPTIONS_JHC -fno-prelude  -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.C.Error+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- C-specific Marshalling support: Handling of C \"errno\" error codes.+--+-----------------------------------------------------------------------------++++module Foreign.C.Error (++  -- * Haskell representations of @errno@ values++  Errno(..),		-- instance: Eq++  -- ** Common @errno@ symbols+  -- | Different operating systems and\/or C libraries often support+  -- different values of @errno@.  This module defines the common values,+  -- but due to the open definition of 'Errno' users may add definitions+  -- which are not predefined.+  eOK,{- e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV, -}++  -- ** 'Errno' functions+                        -- :: Errno+  isValidErrno,		-- :: Errno -> Bool++  -- access to the current thread's "errno" value+  --+  getErrno,             -- :: IO Errno+  resetErrno,           -- :: IO ()++  -- conversion of an "errno" value into IO error+  --+  errnoToIOError,       -- :: String       -- location+                        -- -> Errno        -- errno+                        -- -> Maybe Handle -- handle+                        -- -> Maybe String -- filename+                        -- -> IOError++  -- throw current "errno" value+  --+  throwErrno,           -- ::                String               -> IO a++  -- ** Guards for IO operations that may fail++  throwErrnoIf,         -- :: (a -> Bool) -> String -> IO a       -> IO a+  throwErrnoIf_,        -- :: (a -> Bool) -> String -> IO a       -> IO ()+  throwErrnoIfRetry,    -- :: (a -> Bool) -> String -> IO a       -> IO a+  throwErrnoIfRetry_,   -- :: (a -> Bool) -> String -> IO a       -> IO ()+  throwErrnoIfMinus1,   -- :: Num a+			-- =>                String -> IO a       -> IO a+  throwErrnoIfMinus1_,  -- :: Num a+			-- =>                String -> IO a       -> IO ()+  throwErrnoIfMinus1Retry,+			-- :: Num a+			-- =>                String -> IO a       -> IO a+  throwErrnoIfMinus1Retry_,+			-- :: Num a+			-- =>                String -> IO a       -> IO ()+  throwErrnoIfNull,	-- ::                String -> IO (Ptr a) -> IO (Ptr a)+  throwErrnoIfNullRetry,-- ::                String -> IO (Ptr a) -> IO (Ptr a)++  throwErrnoIfRetryMayBlock,+  throwErrnoIfRetryMayBlock_,+  throwErrnoIfMinus1RetryMayBlock,+  throwErrnoIfMinus1RetryMayBlock_,+  throwErrnoIfNullRetryMayBlock+) where+++import Foreign.C.String+import Foreign.Ptr+import Foreign.Storable+import Jhc.Basics+import Jhc.Basics+import Jhc.IO+import Jhc.Maybe+import Jhc.Monad+import Jhc.Num+import Jhc.Order+import Jhc.Type.C+++++instance Eq Errno where+  errno1@(Errno no1) == errno2@(Errno no2)+    | isValidErrno errno1 && isValidErrno errno2 = no1 == no2+    | otherwise					 = False++-- common "errno" symbols+--+{-+eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV		       :: Errno+-- -}+-- the cCONST_XXX identifiers are cpp symbols whose value is computed by+-- configure+--+eOK             = Errno 0+{-+#ifdef __NHC__+#include "Errno.hs"+#else+e2BIG           = Errno (CONST_E2BIG)+eACCES		= Errno (CONST_EACCES)+eADDRINUSE	= Errno (CONST_EADDRINUSE)+eADDRNOTAVAIL	= Errno (CONST_EADDRNOTAVAIL)+eADV		= Errno (CONST_EADV)+eAFNOSUPPORT	= Errno (CONST_EAFNOSUPPORT)+eAGAIN		= Errno (CONST_EAGAIN)+eALREADY	= Errno (CONST_EALREADY)+eBADF		= Errno (CONST_EBADF)+eBADMSG		= Errno (CONST_EBADMSG)+eBADRPC		= Errno (CONST_EBADRPC)+eBUSY		= Errno (CONST_EBUSY)+eCHILD		= Errno (CONST_ECHILD)+eCOMM		= Errno (CONST_ECOMM)+eCONNABORTED	= Errno (CONST_ECONNABORTED)+eCONNREFUSED	= Errno (CONST_ECONNREFUSED)+eCONNRESET	= Errno (CONST_ECONNRESET)+eDEADLK		= Errno (CONST_EDEADLK)+eDESTADDRREQ	= Errno (CONST_EDESTADDRREQ)+eDIRTY		= Errno (CONST_EDIRTY)+eDOM		= Errno (CONST_EDOM)+eDQUOT		= Errno (CONST_EDQUOT)+eEXIST		= Errno (CONST_EEXIST)+eFAULT		= Errno (CONST_EFAULT)+eFBIG		= Errno (CONST_EFBIG)+eFTYPE		= Errno (CONST_EFTYPE)+eHOSTDOWN	= Errno (CONST_EHOSTDOWN)+eHOSTUNREACH	= Errno (CONST_EHOSTUNREACH)+eIDRM		= Errno (CONST_EIDRM)+eILSEQ		= Errno (CONST_EILSEQ)+eINPROGRESS	= Errno (CONST_EINPROGRESS)+eINTR		= Errno (CONST_EINTR)+eINVAL		= Errno (CONST_EINVAL)+eIO		= Errno (CONST_EIO)+eISCONN		= Errno (CONST_EISCONN)+eISDIR		= Errno (CONST_EISDIR)+eLOOP		= Errno (CONST_ELOOP)+eMFILE		= Errno (CONST_EMFILE)+eMLINK		= Errno (CONST_EMLINK)+eMSGSIZE	= Errno (CONST_EMSGSIZE)+eMULTIHOP	= Errno (CONST_EMULTIHOP)+eNAMETOOLONG	= Errno (CONST_ENAMETOOLONG)+eNETDOWN	= Errno (CONST_ENETDOWN)+eNETRESET	= Errno (CONST_ENETRESET)+eNETUNREACH	= Errno (CONST_ENETUNREACH)+eNFILE		= Errno (CONST_ENFILE)+eNOBUFS		= Errno (CONST_ENOBUFS)+eNODATA		= Errno (CONST_ENODATA)+eNODEV		= Errno (CONST_ENODEV)+eNOENT		= Errno (CONST_ENOENT)+eNOEXEC		= Errno (CONST_ENOEXEC)+eNOLCK		= Errno (CONST_ENOLCK)+eNOLINK		= Errno (CONST_ENOLINK)+eNOMEM		= Errno (CONST_ENOMEM)+eNOMSG		= Errno (CONST_ENOMSG)+eNONET		= Errno (CONST_ENONET)+eNOPROTOOPT	= Errno (CONST_ENOPROTOOPT)+eNOSPC		= Errno (CONST_ENOSPC)+eNOSR		= Errno (CONST_ENOSR)+eNOSTR		= Errno (CONST_ENOSTR)+eNOSYS		= Errno (CONST_ENOSYS)+eNOTBLK		= Errno (CONST_ENOTBLK)+eNOTCONN	= Errno (CONST_ENOTCONN)+eNOTDIR		= Errno (CONST_ENOTDIR)+eNOTEMPTY	= Errno (CONST_ENOTEMPTY)+eNOTSOCK	= Errno (CONST_ENOTSOCK)+eNOTTY		= Errno (CONST_ENOTTY)+eNXIO		= Errno (CONST_ENXIO)+eOPNOTSUPP	= Errno (CONST_EOPNOTSUPP)+ePERM		= Errno (CONST_EPERM)+ePFNOSUPPORT	= Errno (CONST_EPFNOSUPPORT)+ePIPE		= Errno (CONST_EPIPE)+ePROCLIM	= Errno (CONST_EPROCLIM)+ePROCUNAVAIL	= Errno (CONST_EPROCUNAVAIL)+ePROGMISMATCH	= Errno (CONST_EPROGMISMATCH)+ePROGUNAVAIL	= Errno (CONST_EPROGUNAVAIL)+ePROTO		= Errno (CONST_EPROTO)+ePROTONOSUPPORT = Errno (CONST_EPROTONOSUPPORT)+ePROTOTYPE	= Errno (CONST_EPROTOTYPE)+eRANGE		= Errno (CONST_ERANGE)+eREMCHG		= Errno (CONST_EREMCHG)+eREMOTE		= Errno (CONST_EREMOTE)+eROFS		= Errno (CONST_EROFS)+eRPCMISMATCH	= Errno (CONST_ERPCMISMATCH)+eRREMOTE	= Errno (CONST_ERREMOTE)+eSHUTDOWN	= Errno (CONST_ESHUTDOWN)+eSOCKTNOSUPPORT = Errno (CONST_ESOCKTNOSUPPORT)+eSPIPE		= Errno (CONST_ESPIPE)+eSRCH		= Errno (CONST_ESRCH)+eSRMNT		= Errno (CONST_ESRMNT)+eSTALE		= Errno (CONST_ESTALE)+eTIME		= Errno (CONST_ETIME)+eTIMEDOUT	= Errno (CONST_ETIMEDOUT)+eTOOMANYREFS	= Errno (CONST_ETOOMANYREFS)+eTXTBSY		= Errno (CONST_ETXTBSY)+eUSERS		= Errno (CONST_EUSERS)+eWOULDBLOCK	= Errno (CONST_EWOULDBLOCK)+eXDEV		= Errno (CONST_EXDEV)+#endif+-}+-- | Yield 'True' if the given 'Errno' value is valid on the system.+-- This implies that the 'Eq' instance of 'Errno' is also system dependent+-- as it is only defined for valid values of 'Errno'.+--+isValidErrno               :: Errno -> Bool+--+-- the configure script sets all invalid "errno"s to -1+--+isValidErrno (Errno errno)  = errno /= -1+++-- access to the current thread's "errno" value+-- --------------------------------------------++-- | Get the current value of @errno@ in the current thread.+--+getErrno :: IO Errno++-- We must call a C function to get the value of errno in general.  On+-- threaded systems, errno is hidden behind a C macro so that each OS+-- thread gets its own copy.+getErrno = do e <- peek _errno; return (Errno e)+foreign import ccall "errno.h &errno" _errno :: Ptr CInt++-- | Reset the current thread\'s @errno@ value to 'eOK'.+--+resetErrno :: IO ()++-- Again, setting errno has to be done via a C function.+resetErrno = poke _errno 0++-- throw current "errno" value+-- ---------------------------++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'.+--+throwErrno     :: String	-- ^ textual description of the error location+	       -> IO a+throwErrno loc  =+  do+    errno <- getErrno+    ioError (errnoToIOError loc errno Nothing Nothing)+++-- guards for IO operations that may fail+-- --------------------------------------++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the result value of the 'IO' action meets the given predicate.+--+throwErrnoIf    :: (a -> Bool)	-- ^ predicate to apply to the result value+				-- of the 'IO' operation+		-> String	-- ^ textual description of the location+		-> IO a		-- ^ the 'IO' operation to be executed+		-> IO a+throwErrnoIf pred loc f  =+  do+    res <- f+    if pred res then throwErrno loc else return res++-- | as 'throwErrnoIf', but discards the result of the 'IO' action after+-- error handling.+--+throwErrnoIf_   :: (a -> Bool) -> String -> IO a -> IO ()+throwErrnoIf_ pred loc f  = throwErrnoIf pred loc f >> return ()++-- | as 'throwErrnoIf', but retry the 'IO' action when it yields the+-- error code 'eINTR' - this amounts to the standard retry loop for+-- interrupted POSIX system calls.+--+throwErrnoIfRetry            :: (a -> Bool) -> String -> IO a -> IO a+throwErrnoIfRetry pred loc f  =+  do+    res <- f+    if pred res+      then do+	err <- getErrno+	if err == eINTR+	  then throwErrnoIfRetry pred loc f+	  else throwErrno loc+      else return res++-- | as 'throwErrnoIfRetry', but checks for operations that would block and+-- executes an alternative action before retrying in that case.+--+throwErrnoIfRetryMayBlock+		:: (a -> Bool)	-- ^ predicate to apply to the result value+				-- of the 'IO' operation+		-> String	-- ^ textual description of the location+		-> IO a		-- ^ the 'IO' operation to be executed+		-> IO b		-- ^ action to execute before retrying if+				-- an immediate retry would block+		-> IO a+throwErrnoIfRetryMayBlock pred loc f on_block  =+  do+    res <- f+    if pred res+      then do+	err <- getErrno+	if err == eINTR+	  then throwErrnoIfRetryMayBlock pred loc f on_block+          else if err == eWOULDBLOCK || err == eAGAIN+	         then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block+                 else throwErrno loc+      else return res++-- | as 'throwErrnoIfRetry', but discards the result.+--+throwErrnoIfRetry_            :: (a -> Bool) -> String -> IO a -> IO ()+throwErrnoIfRetry_ pred loc f  = throwErrnoIfRetry pred loc f >> return ()++-- | as 'throwErrnoIfRetryMayBlock', but discards the result.+--+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()+throwErrnoIfRetryMayBlock_ pred loc f on_block+  = throwErrnoIfRetryMayBlock pred loc f on_block >> return ()++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns a result of @-1@.+--+throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1  = throwErrnoIf (== -1)++-- | as 'throwErrnoIfMinus1', but discards the result.+--+throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns a result of @-1@, but retries in case of+-- an interrupted operation.+--+throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)++-- | as 'throwErrnoIfMinus1', but discards the result.+--+throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)++-- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.+--+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a+throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)++-- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.+--+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()+throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns 'nullPtr'.+--+throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)+throwErrnoIfNull  = throwErrnoIf (== nullPtr)++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns 'nullPtr',+-- but retry in case of an interrupted operation.+--+throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)+throwErrnoIfNullRetry  = throwErrnoIfRetry (== nullPtr)++-- | as 'throwErrnoIfNullRetry', but checks for operations that would block.+--+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)+throwErrnoIfNullRetryMayBlock  = throwErrnoIfRetryMayBlock (== nullPtr)++-- conversion of an "errno" value into IO error+-- --------------------------------------------++-- | Construct a Haskell 98 I\/O error based on the given 'Errno' value.+-- The optional information can be used to improve the accuracy of+-- error messages.+--+errnoToIOError	:: String	-- ^ the location where the error occurred+		-> Errno	-- ^ the error number+		-> Maybe a	-- ^ optional handle associated with the error+		-> Maybe String	-- ^ optional filename associated with the error+		-> IOError+errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do+    str <- strerror errno >>= peekCString++{-+#if __GLASGOW_HASKELL__+    return (IOError maybeHdl errType loc str maybeName)+    where+    errType+        | errno == eOK             = OtherError+        | errno == e2BIG           = ResourceExhausted+        | errno == eACCES          = PermissionDenied+        | errno == eADDRINUSE      = ResourceBusy+        | errno == eADDRNOTAVAIL   = UnsupportedOperation+        | errno == eADV            = OtherError+        | errno == eAFNOSUPPORT    = UnsupportedOperation+        | errno == eAGAIN          = ResourceExhausted+        | errno == eALREADY        = AlreadyExists+        | errno == eBADF           = OtherError+        | errno == eBADMSG         = InappropriateType+        | errno == eBADRPC         = OtherError+        | errno == eBUSY           = ResourceBusy+        | errno == eCHILD          = NoSuchThing+        | errno == eCOMM           = ResourceVanished+        | errno == eCONNABORTED    = OtherError+        | errno == eCONNREFUSED    = NoSuchThing+        | errno == eCONNRESET      = ResourceVanished+        | errno == eDEADLK         = ResourceBusy+        | errno == eDESTADDRREQ    = InvalidArgument+        | errno == eDIRTY          = UnsatisfiedConstraints+        | errno == eDOM            = InvalidArgument+        | errno == eDQUOT          = PermissionDenied+        | errno == eEXIST          = AlreadyExists+        | errno == eFAULT          = OtherError+        | errno == eFBIG           = PermissionDenied+        | errno == eFTYPE          = InappropriateType+        | errno == eHOSTDOWN       = NoSuchThing+        | errno == eHOSTUNREACH    = NoSuchThing+        | errno == eIDRM           = ResourceVanished+        | errno == eILSEQ          = InvalidArgument+        | errno == eINPROGRESS     = AlreadyExists+        | errno == eINTR           = Interrupted+        | errno == eINVAL          = InvalidArgument+        | errno == eIO             = HardwareFault+        | errno == eISCONN         = AlreadyExists+        | errno == eISDIR          = InappropriateType+        | errno == eLOOP           = InvalidArgument+        | errno == eMFILE          = ResourceExhausted+        | errno == eMLINK          = ResourceExhausted+        | errno == eMSGSIZE        = ResourceExhausted+        | errno == eMULTIHOP       = UnsupportedOperation+        | errno == eNAMETOOLONG    = InvalidArgument+        | errno == eNETDOWN        = ResourceVanished+        | errno == eNETRESET       = ResourceVanished+        | errno == eNETUNREACH     = NoSuchThing+        | errno == eNFILE          = ResourceExhausted+        | errno == eNOBUFS         = ResourceExhausted+        | errno == eNODATA         = NoSuchThing+        | errno == eNODEV          = UnsupportedOperation+        | errno == eNOENT          = NoSuchThing+        | errno == eNOEXEC         = InvalidArgument+        | errno == eNOLCK          = ResourceExhausted+        | errno == eNOLINK         = ResourceVanished+        | errno == eNOMEM          = ResourceExhausted+        | errno == eNOMSG          = NoSuchThing+        | errno == eNONET          = NoSuchThing+        | errno == eNOPROTOOPT     = UnsupportedOperation+        | errno == eNOSPC          = ResourceExhausted+        | errno == eNOSR           = ResourceExhausted+        | errno == eNOSTR          = InvalidArgument+        | errno == eNOSYS          = UnsupportedOperation+        | errno == eNOTBLK         = InvalidArgument+        | errno == eNOTCONN        = InvalidArgument+        | errno == eNOTDIR         = InappropriateType+        | errno == eNOTEMPTY       = UnsatisfiedConstraints+        | errno == eNOTSOCK        = InvalidArgument+        | errno == eNOTTY          = IllegalOperation+        | errno == eNXIO           = NoSuchThing+        | errno == eOPNOTSUPP      = UnsupportedOperation+        | errno == ePERM           = PermissionDenied+        | errno == ePFNOSUPPORT    = UnsupportedOperation+        | errno == ePIPE           = ResourceVanished+        | errno == ePROCLIM        = PermissionDenied+        | errno == ePROCUNAVAIL    = UnsupportedOperation+        | errno == ePROGMISMATCH   = ProtocolError+        | errno == ePROGUNAVAIL    = UnsupportedOperation+        | errno == ePROTO          = ProtocolError+        | errno == ePROTONOSUPPORT = ProtocolError+        | errno == ePROTOTYPE      = ProtocolError+        | errno == eRANGE          = UnsupportedOperation+        | errno == eREMCHG         = ResourceVanished+        | errno == eREMOTE         = IllegalOperation+        | errno == eROFS           = PermissionDenied+        | errno == eRPCMISMATCH    = ProtocolError+        | errno == eRREMOTE        = IllegalOperation+        | errno == eSHUTDOWN       = IllegalOperation+        | errno == eSOCKTNOSUPPORT = UnsupportedOperation+        | errno == eSPIPE          = UnsupportedOperation+        | errno == eSRCH           = NoSuchThing+        | errno == eSRMNT          = UnsatisfiedConstraints+        | errno == eSTALE          = ResourceVanished+        | errno == eTIME           = TimeExpired+        | errno == eTIMEDOUT       = TimeExpired+        | errno == eTOOMANYREFS    = ResourceExhausted+        | errno == eTXTBSY         = ResourceBusy+        | errno == eUSERS          = ResourceExhausted+        | errno == eWOULDBLOCK     = OtherError+        | errno == eXDEV           = UnsupportedOperation+        | otherwise                = OtherError+#else+#endif+-}+    return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))+-- #endif++foreign import ccall  "string.h strerror" strerror :: Errno -> IO (Ptr CChar)+foreign import primitive "const.EINTR" eINTR :: Errno+foreign import primitive "const.EWOULDBLOCK" eWOULDBLOCK :: Errno+foreign import primitive "const.EAGAIN" eAGAIN :: Errno
+ lib/jhc/Foreign/C/String.hs view
@@ -0,0 +1,455 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.C.String+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for primitive marshalling of C strings.+--+-- The marshalling converts each Haskell character, representing a Unicode+-- code point, to one or more bytes in a manner that, by default, is+-- determined by the current locale.  As a consequence, no guarantees+-- can be made about the relative length of a Haskell string and its+-- corresponding C string, and therefore all the marshalling routines+-- include memory allocation.  The translation between Unicode and the+-- encoding of the current locale may be lossy.+--+-----------------------------------------------------------------------------++module Foreign.C.String (   -- representation of strings in C++  -- * C strings++  CString,           -- = Ptr CChar+  CStringLen,        -- = (Ptr CChar, Int)++  -- ** Using a locale-dependent encoding++  -- | Currently these functions are identical to their @CAString@ counterparts;+  -- eventually they will use an encoding determined by the current locale.++  -- conversion of C strings into Haskell strings+  --+  peekCString,       -- :: CString    -> IO String+  peekCStringLen,    -- :: CStringLen -> IO String++  -- conversion of Haskell strings into C strings+  --+  newCString,        -- :: String -> IO CString+  newCStringLen,     -- :: String -> IO CStringLen++  -- conversion of Haskell strings into C strings using temporary storage+  --+  withCString,       -- :: String -> (CString    -> IO a) -> IO a+  withCStringLen,    -- :: String -> (CStringLen -> IO a) -> IO a++  charIsRepresentable, -- :: Char -> IO Bool++  -- ** Using 8-bit characters++  -- | These variants of the above functions are for use with C libraries+  -- that are ignorant of Unicode.  These functions should be used with+  -- care, as a loss of information can occur.++  castCharToCChar,   -- :: Char -> CChar+  castCCharToChar,   -- :: CChar -> Char++  peekCAString,      -- :: CString    -> IO String+  peekCAStringLen,   -- :: CStringLen -> IO String+  newCAString,       -- :: String -> IO CString+  newCAStringLen,    -- :: String -> IO CStringLen+  withCAString,      -- :: String -> (CString    -> IO a) -> IO a+  withCAStringLen,   -- :: String -> (CStringLen -> IO a) -> IO a++  -- * C wide strings++  -- | These variants of the above functions are for use with C libraries+  -- that encode Unicode using the C @wchar_t@ type in a system-dependent+  -- way.  The only encodings supported are+  --+  -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or+  --+  -- * UTF-16 (as used on Windows systems).++  CWString,          -- = Ptr CWchar+  CWStringLen,       -- = (Ptr CWchar, Int)++  peekCWString,      -- :: CWString    -> IO String+  peekCWStringLen,   -- :: CWStringLen -> IO String+  newCWString,       -- :: String -> IO CWString+  newCWStringLen,    -- :: String -> IO CWStringLen+  withCWString,      -- :: String -> (CWString    -> IO a) -> IO a+  withCWStringLen,   -- :: String -> (CWStringLen -> IO a) -> IO a++  ) where++import Jhc.Basics+import Jhc.Monad+import Jhc.Order+import Jhc.List+import Jhc.Num+import Foreign.Marshal.Array+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+++-----------------------------------------------------------------------------+-- Strings++-- representation of strings in C+-- ------------------------------++-- | A C string is a reference to an array of C characters terminated by NUL.+type CString    = Ptr CChar++-- | A string with explicit length information in bytes instead of a+-- terminating NUL (allowing NUL characters in the middle of the string).+type CStringLen = (Ptr CChar, Int)++-- exported functions+-- ------------------+--+-- * the following routines apply the default conversion when converting the+--   C-land character encoding into the Haskell-land character encoding++-- | Marshal a NUL terminated C string into a Haskell string.+--+peekCString    :: CString -> IO String+peekCString = peekCAString++-- | Marshal a C string with explicit length into a Haskell string.+--+peekCStringLen           :: CStringLen -> IO String+peekCStringLen = peekCAStringLen++-- | Marshal a Haskell string into a NUL terminated C string.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCString :: String -> IO CString+newCString = newCAString++-- | Marshal a Haskell string into a C string (ie, character array) with+-- explicit length information.+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCStringLen     :: String -> IO CStringLen+newCStringLen = newCAStringLen++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCString :: String -> (CString -> IO a) -> IO a+withCString = withCAString++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCStringLen         :: String -> (CStringLen -> IO a) -> IO a+withCStringLen = withCAStringLen++-- | Determines whether a character can be accurately encoded in a 'CString'.+-- Unrepresentable characters are converted to @\'?\'@.+--+-- Currently only Latin-1 characters are representable.+charIsRepresentable :: Char -> IO Bool+charIsRepresentable c = return (ord c < 256)++-- single byte characters+-- ----------------------+--+--   ** NOTE: These routines don't handle conversions! **++-- | Convert a C byte, representing a Latin-1 character, to the corresponding+-- Haskell character.+--castCCharToChar :: CChar -> Char+--castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))++-- | Convert a Haskell character to a C character.+-- This function is only safe on the first 256 characters.+--castCharToCChar :: Char -> CChar+--castCharToCChar ch = fromIntegral (ord ch)++foreign import primitive "U2U" castCCharToChar :: CChar -> Char+foreign import primitive "U2U" castCharToCChar :: Char -> CChar++-- | Marshal a NUL terminated C string into a Haskell string.+--+peekCAString    :: CString -> IO String+--  #ifndef __GLASGOW_HASKELL__+--peekCAString cp  = do+--  cs <- peekArray0 nUL cp+--  return (cCharsToChars cs)+--  #else+peekCAString cp = do+  l <- lengthArray0 nUL cp+  if l <= 0 then return "" else loop "" (l-1) where+    loop s i = do+        xval <- peekElemOff cp i+	let val = castCCharToChar xval+	val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)+--  #endif++-- | Marshal a C string with explicit length into a Haskell string.+--+peekCAStringLen           :: CStringLen -> IO String+--  #ifndef __GLASGOW_HASKELL__+-- peekCAStringLen (cp, len)  = do+--   cs <- peekArray len cp+--  return (cCharsToChars cs)+--  #else+peekCAStringLen (cp, len)+  | len <= 0  = return "" -- being (too?) nice.+  | otherwise = loop [] (len-1)+  where+    loop acc i = do+         xval <- peekElemOff cp i+	 let val = castCCharToChar xval+	   -- blow away the coercion ASAP.+	 if (val `seq` (i == 0))+	  then return (val:acc)+	  else loop (val:acc) (i-1)+--  #endif++-- | Marshal a Haskell string into a NUL terminated C string.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCAString :: String -> IO CString+--  #ifndef __GLASGOW_HASKELL__+-- newCAString  = newArray0 nUL . charsToCChars+--  #else+newCAString str = do+  ptr <- mallocArray0 (length str)+  let+	go [] n     = pokeElemOff ptr n nUL+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+  go str 0+  return ptr+--  #endif++-- | Marshal a Haskell string into a C string (ie, character array) with+-- explicit length information.+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCAStringLen     :: String -> IO CStringLen+--  #ifndef __GLASGOW_HASKELL__+-- newCAStringLen str  = do+--   a <- newArray (charsToCChars str)+--  return (pairLength str a)+--  #else+newCAStringLen str = do+  ptr <- mallocArray0 len+  let+	go [] n     = n `seq` return ()	-- make it strict in n+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+  go str 0+  return (ptr, len) where+    len = length str+--  #endif++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCAString :: String -> (CString -> IO a) -> IO a+--  #ifndef __GLASGOW_HASKELL__+-- withCAString  = withArray0 nUL . charsToCChars+--  #else+withCAString str f =+  allocaArray0 (length str) $ \ptr ->+      let+	go [] n     = pokeElemOff ptr n nUL+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+      in do+      go str 0+      f ptr+-- #endif++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+-- withCAStringLen         :: String -> (CStringLen -> IO a) -> IO a+--  #ifndef __GLASGOW_HASKELL__+-- withCAStringLen str act  = withArray (charsToCChars str) $ act . pairLength str+--  #else+withCAStringLen str f =+  allocaArray len $ \ptr ->+      let+	go [] n     = n `seq` return ()	-- make it strict in n+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+      in do+      go str 0+      f (ptr,len)+  where+    len = length str+--  #endif++-- auxiliary definitions+-- ----------------------++-- C's end of string character+--+nUL :: CChar+nUL  = 0++-- pair a C string with the length of the given Haskell string+--+pairLength :: String -> a -> (a, Int)+pairLength  = flip (,) . length++--  #ifndef __GLASGOW_HASKELL__+-- cast [CChar] to [Char]+--+cCharsToChars :: [CChar] -> [Char]+cCharsToChars xs  = map castCCharToChar xs++-- cast [Char] to [CChar]+--+charsToCChars :: [Char] -> [CChar]+charsToCChars xs  = map castCharToCChar xs+--   #endif++-----------------------------------------------------------------------------+-- Wide strings++-- representation of wide strings in C+-- -----------------------------------++-- | A C wide string is a reference to an array of C wide characters+-- terminated by NUL.+type CWString    = Ptr CWchar++-- | A wide character string with explicit length information in bytes+-- instead of a terminating NUL (allowing NUL characters in the middle+-- of the string).+type CWStringLen = (Ptr CWchar, Int)++-- | Marshal a NUL terminated C wide string into a Haskell string.+--+peekCWString    :: CWString -> IO String+peekCWString cp  = do+  cs <- peekArray0 wNUL cp+  return (cWcharsToChars cs)++-- | Marshal a C wide string with explicit length into a Haskell string.+--+peekCWStringLen           :: CWStringLen -> IO String+peekCWStringLen (cp, len)  = do+  cs <- peekArray len cp+  return (cWcharsToChars cs)++-- | Marshal a Haskell string into a NUL terminated C wide string.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * new storage is allocated for the C wide string and must+--   be explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCWString :: String -> IO CWString+newCWString  = newArray0 wNUL . charsToCWchars++-- | Marshal a Haskell string into a C wide string (ie, wide character array)+-- with explicit length information.+--+-- * new storage is allocated for the C wide string and must+--   be explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCWStringLen     :: String -> IO CWStringLen+newCWStringLen str  = do+  a <- newArray (charsToCWchars str)+  return (pairLength str a)++-- | Marshal a Haskell string into a NUL terminated C wide string using+-- temporary storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCWString :: String -> (CWString -> IO a) -> IO a+withCWString  = withArray0 wNUL . charsToCWchars++-- | Marshal a Haskell string into a NUL terminated C wide string using+-- temporary storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a+withCWStringLen str act  = withArray (charsToCWchars str) $ act . pairLength str++-- auxiliary definitions+-- ----------------------++wNUL :: CWchar+wNUL = 0++cWcharsToChars :: [CWchar] -> [Char]+charsToCWchars :: [Char] -> [CWchar]+++cWcharsToChars xs  = map castCWcharToChar xs+charsToCWchars xs  = map castCharToCWchar xs++-- These conversions only make sense if __STDC_ISO_10646__ is defined+-- (meaning that wchar_t is ISO 10646, aka Unicode)++--castCWcharToChar :: CWchar -> Char+--castCWcharToChar ch = chr (fromIntegral ch )++--castCharToCWchar :: Char -> CWchar+--castCharToCWchar ch = fromIntegral (ord ch)++foreign import primitive "U2U" castCWcharToChar :: CWchar -> Char+foreign import primitive "U2U" castCharToCWchar :: Char -> CWchar
+ lib/jhc/Foreign/C/Types.hs view
@@ -0,0 +1,9 @@+-- Haskell 2010 compliant+module Foreign.C.Types (+    CChar,  CSChar,  CUChar,  CShort,  CUShort,  CInt,  CUInt,  CLong,  CULong,+    CPtrdiff,  CSize,  CWchar,  CSigAtomic,  CLLong,  CULLong,  CIntPtr,+    CUIntPtr,  CIntMax,  CUIntMax,  CClock,  CTime,  CFloat,  CDouble,  CFile,+    CFpos,  CJmpBuf+  ) where++import Jhc.Type.C
+ lib/jhc/Foreign/Marshal/Alloc.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+module Foreign.Marshal.Alloc (+  -- * Memory allocation+  -- ** Local allocation+  alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b+  allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b++  -- ** Dynamic allocation+  malloc,       -- :: Storable a =>        IO (Ptr a)+  mallocBytes,  -- ::               Int -> IO (Ptr a)++  realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)+  reallocBytes, -- ::		    Ptr a -> Int -> IO (Ptr a)++  free,         -- :: Ptr a -> IO ()+  finalizerFree -- :: FinalizerPtr a+) where++import Foreign.C.Types+import Foreign.Storable+import Jhc.Addr+import Jhc.Basics+import Jhc.IO+import Jhc.Int(unboxInt)+import Jhc.Monad+import Jhc.Num+import Jhc.Order+import qualified Jhc.Options as JO++-- TODO handle exceptions+allocaBytes' :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes' b f = do+    p <- mallocBytes b+    r <- f p+    free p+    return r++allocaBytes :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes num fn = etaIO $ case JO.target of+    JO.GhcHs -> case unboxInt num of n -> alloca__ n (\addr -> fn (boxAddr addr))+    _ -> allocaBytes' num fn++foreign import primitive alloca__ :: Int__ -> (Addr__ -> IO b) -> IO b+foreign import primitive "box" boxAddr :: Addr__ -> Ptr a++-- exported functions+-- ------------------++-- |Allocate a block of memory that is sufficient to hold values of type+-- @a@.  The size of the area allocated is determined by the 'sizeOf'+-- method from the instance of 'Storable' for the appropriate type.+--+-- The memory may be deallocated using 'free' or 'finalizerFree' when+-- no longer required.+--+malloc :: Storable a => IO (Ptr a)+malloc  = doMalloc undefined+doMalloc       :: Storable b => b -> IO (Ptr b)+doMalloc dummy  = mallocBytes (sizeOf dummy)++-- |@'alloca' f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory sufficient to+-- hold values of type @a@.+--+-- The memory is freed when @f@ terminates (either normally or via an+-- exception), so the pointer passed to @f@ must /not/ be used after this.+--+alloca :: Storable a => (Ptr a -> IO b) -> IO b+alloca fn  = etaIO $ doAlloca undefined fn where+    doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy fn = allocaBytes (sizeOf dummy) fn++{-# INLINE failWhenNULL #-}+failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)+failWhenNULL name f = do+   addr <- f+   failWhenNULL' name addr++failWhenNULL' :: String -> Ptr a -> IO (Ptr a)+failWhenNULL' name addr = do+   if addr == nullPtr+      then ioError (userError (name++": out of memory"))+      else return addr++-- |Allocate a block of memory of the given number of bytes.+-- The block of memory is sufficiently aligned for any of the basic+-- foreign types that fits into a memory block of the allocated size.+--+-- The memory may be deallocated using 'free' or 'finalizerFree' when+-- no longer required.+mallocBytes      :: Int -> IO (Ptr a)+mallocBytes size  = _malloc (fromIntegral size) >>= failWhenNULL' "malloc"++-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'+-- to the size needed to store values of type @b@.  The returned pointer+-- may refer to an entirely different memory area, but will be suitably+-- aligned to hold values of type @b@.  The contents of the referenced+-- memory area will be the same as of the original pointer up to the+-- minimum of the original size and the size of values of type @b@.+--+-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like+-- 'malloc'.+--+realloc :: Storable b => Ptr a -> IO (Ptr b)+realloc  = doRealloc undefined+doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')+doRealloc dummy ptr  = let+                         size = fromIntegral (sizeOf dummy)+                       in+                       (_realloc ptr size) >>= failWhenNULL' "realloc"++-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'+-- to the given size.  The returned pointer may refer to an entirely+-- different memory area, but will be sufficiently aligned for any of the+-- basic foreign types that fits into a memory block of the given size.+-- The contents of the referenced memory area will be the same as of+-- the original pointer up to the minimum of the original size and the+-- given size.+--+-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'+-- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'+-- behaves like 'free'.+--+reallocBytes          :: Ptr a -> Int -> IO (Ptr a)+reallocBytes ptr i | ptr `seq` i `seq` False = undefined+reallocBytes ptr 0     = do free ptr; return nullPtr+reallocBytes ptr size  =+  _realloc ptr (fromIntegral size) >>= failWhenNULL' "realloc"++foreign import ccall "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a)+foreign import ccall "stdlib.h free" free :: Ptr a -> IO ()+foreign import ccall "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)++-- | A pointer to a foreign function equivalent to 'free', which may be+-- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage+-- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.+foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FunPtr (Ptr a -> IO ())
+ lib/jhc/Foreign/Marshal/Array.hs view
@@ -0,0 +1,248 @@+{-# OPTIONS_JHC -fno-prelude  #-}+module Foreign.Marshal.Array (+  -- * Marshalling arrays++  -- ** Allocation+  --+  mallocArray,    -- :: Storable a => Int -> IO (Ptr a)+  mallocArray0,   -- :: Storable a => Int -> IO (Ptr a)++  allocaArray,    -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b+  allocaArray0,   -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b++  reallocArray,   -- :: Storable a => Ptr a -> Int -> IO (Ptr a)+  reallocArray0,  -- :: Storable a => Ptr a -> Int -> IO (Ptr a)++  -- ** Marshalling+  --+  peekArray,      -- :: Storable a =>         Int -> Ptr a -> IO [a]+  peekArray0,     -- :: (Storable a, Eq a) => a   -> Ptr a -> IO [a]++  pokeArray,      -- :: Storable a =>      Ptr a -> [a] -> IO ()+  pokeArray0,     -- :: Storable a => a -> Ptr a -> [a] -> IO ()++  -- ** Combined allocation and marshalling+  --+  newArray,       -- :: Storable a =>      [a] -> IO (Ptr a)+  newArray0,      -- :: Storable a => a -> [a] -> IO (Ptr a)++  withArray,      -- :: Storable a =>      [a] -> (Ptr a -> IO b) -> IO b+  withArray0,     -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b++  withArrayLen,   -- :: Storable a =>      [a] -> (Int -> Ptr a -> IO b) -> IO b+  withArrayLen0,  -- :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b++  -- ** Copying++  -- | (argument order: destination, source)+  copyArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+  moveArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()++  -- ** Finding the length+  --+  lengthArray0,   -- :: (Storable a, Eq a) => a -> Ptr a -> IO Int++  -- ** Indexing+  --+  advancePtr,     -- :: Storable a => Ptr a -> Int -> Ptr a+) where++import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Jhc.Basics+import Jhc.IO+import Jhc.List+import Jhc.Monad+import Jhc.Num+import Jhc.Order++-- allocation+-- ----------++-- |Allocate storage for the given number of elements of a storable type+-- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).+--+mallocArray :: Storable a => Int -> IO (Ptr a)+mallocArray  = doMalloc undefined+doMalloc            :: Storable a' => a' -> Int -> IO (Ptr a')+doMalloc dummy size  = mallocBytes (size * sizeOf dummy)++-- |Like 'mallocArray', but add an extra position to hold a special+-- termination element.+--+mallocArray0      :: Storable a => Int -> IO (Ptr a)+mallocArray0 size  = mallocArray (size + 1)++-- |Temporarily allocate space for the given number of elements+-- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).+--+allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray  size fn = etaIO $ doAlloca undefined fn where+    doAlloca            :: Storable a' => a' ->  (Ptr a' -> IO b') -> IO b'+    doAlloca dummy fn = allocaBytes (size * sizeOf dummy) fn++-- |Like 'allocaArray', but add an extra position to hold a special+-- termination element.+--+allocaArray0      :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray0 size  = allocaArray (size + 1)++-- |Adjust the size of an array+--+reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a)+reallocArray  = doRealloc undefined+  where+    doRealloc                :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a')+    doRealloc dummy ptr size  = reallocBytes ptr (size * sizeOf dummy)++-- |Adjust the size of an array including an extra position for the end marker.+--+reallocArray0          :: Storable a => Ptr a -> Int -> IO (Ptr a)+reallocArray0 ptr size  = reallocArray ptr (size + 1)++-- |Convert an array of given length into a Haskell list.  This version+-- traverses the array backwards using an accumulating parameter,+-- which uses constant stack space.  The previous version using mapM+-- needed linear stack space.+--+peekArray          :: Storable a => Int -> Ptr a -> IO [a]+peekArray size ptr | ptr `seq` (size <= 0) = return []+                   | otherwise = f (size-1) []+  where+    f 0 acc = do e <- peekElemOff ptr 0; return (e:acc)+    f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc)++-- |Convert an array terminated by the given end marker into a Haskell list+--+peekArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO [a]+peekArray0 marker ptr  = do+  size <- lengthArray0 marker ptr+  peekArray size ptr++-- finding the length+-- ------------------++-- |Write the list elements consecutive into memory+--+--pokeArray :: Storable a => Ptr a -> [a] -> IO ()+--pokeArray ptr vals =  zipWithM_ (pokeElemOff ptr) [0..] vals where+--    zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+--    zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++pokeArray :: Storable a => Ptr a -> [a] -> IO ()+pokeArray ptr vals = pokeArray' ptr vals >> return ()++pokeArray' :: Storable a => Ptr a -> [a] -> IO Int+pokeArray' ptr vals =  etaIO $ f 0 vals where+    f n [] | n `seq` True = return n+    f n (x:xs) = pokeElemOff ptr n x >> f (n + 1) xs++-- |Write the list elements consecutive into memory and terminate them with the+-- given marker element+--+pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()+pokeArray0 marker ptr vals  = do+  lv <- pokeArray' ptr vals+  pokeElemOff ptr lv marker++-- combined allocation and marshalling+-- -----------------------------------++-- |Write a list of storable elements into a newly allocated, consecutive+-- sequence of storable values+-- (like 'Foreign.Marshal.Utils.new', but for multiple elements).+--+newArray      :: Storable a => [a] -> IO (Ptr a)+newArray vals  = do+  ptr <- mallocArray (length vals)+  pokeArray ptr vals+  return ptr++-- |Write a list of storable elements into a newly allocated, consecutive+-- sequence of storable values, where the end is fixed by the given end marker+--+newArray0             :: Storable a => a -> [a] -> IO (Ptr a)+newArray0 marker vals  = do+  ptr <- mallocArray0 (length vals)+  pokeArray0 marker ptr vals+  return ptr++-- |Temporarily store a list of storable values in memory+-- (like 'Foreign.Marshal.Utils.with', but for multiple elements).+--+withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b+withArray vals = withArrayLen vals . const++-- |Like 'withArray', but the action gets the number of values+-- as an additional parameter+--+withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen vals f  = etaIO $+  len `seq` allocaArray len $ \ptr -> do+      pokeArray ptr vals+      res <- f len ptr+      return res+  where+    len = length vals++-- |Like 'withArray', but a terminator indicates where the array ends+--+withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b+withArray0 marker vals = withArrayLen0 marker vals . const++-- |Like 'withArrayLen', but a terminator indicates where the array ends+--+withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen0 marker vals f  = etaIO $+  len `seq` allocaArray0 len $ \ptr -> do+      pokeArray0 marker ptr vals+      res <- f len ptr+      return res+  where+    len = length vals++-- copying (argument order: destination, source)+-- -------++-- |Copy the given number of elements from the second array (source) into the+-- first array (destination); the copied areas may /not/ overlap+--+copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+copyArray  = doCopy undefined+  where+    doCopy                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()+    doCopy dummy dest src size  = copyBytes dest src (size * sizeOf dummy)++-- |Copy the given number of elements from the second array (source) into the+-- first array (destination); the copied areas /may/ overlap+--+moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+moveArray  = doMove undefined+  where+    doMove                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()+    doMove dummy dest src size  = moveBytes dest src (size * sizeOf dummy)++-- finding the length+-- ------------------++-- |Return the number of elements in an array, excluding the terminator+--+lengthArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO Int+lengthArray0 marker ptr | ptr `seq` True  = etaIO $ loop 0+  where+    loop i | i `seq` True = do+        val <- peekElemOff ptr i+        if val == marker then return i else loop (i+1)++-- indexing+-- --------++-- |Advance a pointer into an array by the given number of elements+--+advancePtr :: Storable a => Ptr a -> Int -> Ptr a+advancePtr  = doAdvance undefined+  where+    doAdvance             :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'+    doAdvance dummy ptr i  = ptr `plusPtr` (i * sizeOf dummy)
+ lib/jhc/Foreign/Marshal/Utils.hs view
@@ -0,0 +1,171 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Utils+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for primitive marshaling+--+-----------------------------------------------------------------------------++module Foreign.Marshal.Utils (+  -- * General marshalling utilities++  -- ** Combined allocation and marshalling+  --+  with,          -- :: Storable a => a -> (Ptr a -> IO b) -> IO b+  new,           -- :: Storable a => a -> IO (Ptr a)++  -- ** Marshalling of Boolean values (non-zero corresponds to 'True')+  --+  fromBool,      -- :: Num a => Bool -> a+  toBool,	 -- :: Num a => a -> Bool++  -- ** Marshalling of Maybe values+  --+  maybeNew,      -- :: (      a -> IO (Ptr a))+		 -- -> (Maybe a -> IO (Ptr a))+  maybeWith,     -- :: (      a -> (Ptr b -> IO c) -> IO c)+		 -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)+  maybePeek,     -- :: (Ptr a -> IO        b )+		 -- -> (Ptr a -> IO (Maybe b))++  -- ** Marshalling lists of storable objects+  --+  withMany,      -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res++  -- ** Haskellish interface to memcpy and memmove+  -- | (argument order: destination, source)+  --+  copyBytes,     -- :: Ptr a -> Ptr a -> Int -> IO ()+  moveBytes     -- :: Ptr a -> Ptr a -> Int -> IO ()++) where++import Foreign.Ptr	        ( Ptr, nullPtr )+import Foreign.Storable		( Storable(poke) )+import Foreign.C.Types    	( CSize )+import Foreign.Marshal.Alloc 	( malloc, alloca )+import Jhc.Basics+import Jhc.Monad+import Jhc.Num+import Jhc.Order+import Jhc.Inst.Storable()++-- combined allocation and marshalling+-- -----------------------------------++-- |Allocate a block of memory and marshal a value into it+-- (the combination of 'malloc' and 'poke').+-- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf'+-- method from the instance of 'Storable' for the appropriate type.+--+-- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or+-- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required.+--+new     :: Storable a => a -> IO (Ptr a)+new val  =+  do+    ptr <- malloc+    poke ptr val+    return ptr++-- |@'with' val f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory into which+-- 'val' has been marshalled (the combination of 'alloca' and 'poke').+--+-- The memory is freed when @f@ terminates (either normally or via an+-- exception), so the pointer passed to @f@ must /not/ be used after this.+--+with       :: Storable a => a -> (Ptr a -> IO b) -> IO b+with val f  =+  alloca $ \ptr -> do+    poke ptr val+    res <- f ptr+    return res++-- marshalling of Boolean values (non-zero corresponds to 'True')+-- -----------------------------++-- |Convert a Haskell 'Bool' to its numeric representation+--+fromBool       :: Num a => Bool -> a+fromBool False  = 0+fromBool True   = 1++-- |Convert a Boolean in numeric representation to a Haskell value+--+toBool :: Num a => a -> Bool+toBool  = (/= 0)++-- marshalling of Maybe values+-- ---------------------------++-- |Allocate storage and marshall a storable value wrapped into a 'Maybe'+--+-- * the 'nullPtr' is used to represent 'Nothing'+--+maybeNew :: (      a -> IO (Ptr a))+	 -> (Maybe a -> IO (Ptr a))+maybeNew  = maybe (return nullPtr)++-- |Converts a @withXXX@ combinator into one marshalling a value wrapped+-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.+--+maybeWith :: (      a -> (Ptr b -> IO c) -> IO c)+	  -> (Maybe a -> (Ptr b -> IO c) -> IO c)+maybeWith  = maybe ($ nullPtr)++-- |Convert a peek combinator into a one returning 'Nothing' if applied to a+-- 'nullPtr'+--+maybePeek                           :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)+maybePeek peek ptr | ptr == nullPtr  = return Nothing+		   | otherwise       = do a <- peek ptr; return (Just a)++-- marshalling lists of storable objects+-- -------------------------------------++-- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of+-- marshalled objects+--+withMany :: (a -> (b -> res) -> res)  -- withXXX combinator for one object+	 -> [a]			      -- storable objects+	 -> ([b] -> res)	      -- action on list of marshalled obj.s+	 -> res+withMany _       []     f = f []+withMany withFoo (x:xs) f = withFoo x $ \x' ->+			      withMany withFoo xs (\xs' -> f (x':xs'))++-- Haskellish interface to memcpy and memmove+-- ------------------------------------------++-- |Copies the given number of bytes from the second area (source) into the+-- first (destination); the copied areas may /not/ overlap+--+copyBytes               :: Ptr a -> Ptr a -> Int -> IO ()+copyBytes dest src size  = memcpy dest src (fromIntegral size)++-- |Copies the given number of elements from the second area (source) into the+-- first (destination); the copied areas /may/ overlap+--+moveBytes               :: Ptr a -> Ptr a -> Int -> IO ()+moveBytes dest src size  = memmove dest src (fromIntegral size)++-- auxilliary routines+-- -------------------++-- |Basic C routines needed for memory copying+--+foreign import ccall  "string.h memcpy" memcpy  :: Ptr a -> Ptr a -> CSize -> IO ()+foreign import ccall  "string.h memmove" memmove :: Ptr a -> Ptr a -> CSize -> IO ()++maybe :: b -> (a -> b) -> Maybe a -> b+maybe n f m = case m of+    Just x -> f x+    Nothing -> n
+ lib/jhc/Foreign/Ptr.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-tuples #-}++module Foreign.Ptr(+    Ptr(),+    nullPtr,+    castPtr,+    plusPtr,+    alignPtr,+    minusPtr,+    FunPtr(),+    nullFunPtr,+    castFunPtr,+    castFunPtrToPtr,+    castPtrToFunPtr,+    freeHaskellFunPtr+    ) where++import Jhc.Addr+import Jhc.Basics+import Jhc.IO+import Jhc.Inst.Show+import Jhc.Show++instance Show (Ptr a) where+    showsPrec n x = showsPrec n ((ptrToWordPtr  x))++alignPtr :: Ptr a -> Int -> Ptr a+alignPtr = error "alignPtr"+--alignPtr addr@(Ptr a) (I# i)+--  = case remAddr# a i of {+--      0# -> addr;+--      n -> Ptr (plusAddr# a (i -# n)) }++castFunPtr :: FunPtr a -> FunPtr b+castFunPtr (FunPtr x) = FunPtr x++castFunPtrToPtr :: FunPtr a -> Ptr b+castFunPtrToPtr (FunPtr (FunAddr_ x)) = Ptr (Addr_ x)++castPtrToFunPtr :: Ptr a -> FunPtr b+castPtrToFunPtr (Ptr (Addr_ x)) = FunPtr (FunAddr_ x)++freeHaskellFunPtr :: FunPtr a -> IO ()+freeHaskellFunPtr _ = error "freeHaskellFunPtr"++--foreign import primitive "U2U" ptrToWordPtr :: Ptr a -> WordPtr+--foreign import primitive "U2U" wordPtrToPtr :: WordPtr -> Ptr a++ptrToWordPtr :: Ptr a -> WordPtr+ptrToWordPtr (Ptr w) = boxWordPtr w++wordPtrToPtr :: WordPtr -> Ptr a+wordPtrToPtr w = Ptr (unboxWordPtr w)++foreign import primitive "box" boxWordPtr :: Addr_ -> WordPtr+foreign import primitive "unbox" unboxWordPtr :: WordPtr -> Addr_
+ lib/jhc/Foreign/Storable.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_JHC -fno-prelude -fm4 -funboxed-values -funboxed-tuples -fffi #-}+module Foreign.Storable(Storable(..)) where++import Jhc.Addr+import Jhc.Basics+import Jhc.IO+import Jhc.Int++m4_include(Foreign/Storable.m4)++class Storable a where+    sizeOf :: a -> Int+    alignment :: a -> Int+    peekElemOff :: Ptr a -> Int -> IO a+    pokeElemOff :: Ptr a -> Int -> a -> IO ()+    peekByteOff :: Ptr b -> Int -> IO a+    pokeByteOff :: Ptr b -> Int -> a -> IO ()+    peek :: Ptr a -> IO a+    poke :: Ptr a -> a -> IO ()++    alignment x = sizeOf x+    peekElemOff addr idx = fromUIO $ \w -> unIO (peek $! (addr `plusPtr` (idx `times` sizeOf (_f addr)))) w+    pokeElemOff addr idx x = fromUIO $ \w -> unIO (let adr = (addr `plusPtr` (idx `times` sizeOf x)) in adr `seq` poke adr x) w+    peekByteOff addr off = fromUIO $ \w -> unIO (peek $! (castPtr $ addr `plusPtr` off)) w+    pokeByteOff addr off x = fromUIO $ \w -> unIO (let adr = castPtr (addr `plusPtr` off) in adr `seq` poke adr x) w++_f :: Ptr a -> a+_f _ = undefined++INST_STORABLE_X((Ptr a),Ptr,Addr_,bits<ptr>)+INST_STORABLE_X((FunPtr a),FunPtr,FunAddr_,bits<ptr>)++-- foreign import "Add" plusBitsPtr_ :: BitsPtr_ -> Int -> BitsPtr_
+ lib/jhc/Foreign/Storable.m4 view
@@ -0,0 +1,40 @@+m4_divert(-1)++m4_define(INST_STORABLE_X,{{+instance Storable $1 where+    peek (Ptr addr) = fromUIO $ \w -> case peek$2 addr w of+        (# w', r #) -> (# w', $2 r #)+    poke (Ptr addr) ($2 v) = fromUIO $ \w -> case poke$2 addr v w of+        w' -> (# w', () #)+    sizeOf _ = Int (sizeOf$2 0#)+    alignment _ = Int (alignmentOf$2 0#)+ONCE({{+foreign import primitive "peek.$4" peek$2 :: Addr_ -> UIO $3+foreign import primitive "poke.$4" poke$2 :: Addr_ -> $3 -> UIO_+foreign import primitive "sizeOf.$4" sizeOf$2 :: Int__ -> Int__+foreign import primitive "alignmentOf.$4" alignmentOf$2 :: Int__ -> Int__+}})+}})++m4_define(INST_STORABLE_YY,{{+instance Storable $1 where+    peek (Ptr addr) = fromUIO $ \w -> case peek$2 addr w of+        (# w', r #) -> (# w', box$2 r #)+    poke (Ptr addr) v = fromUIO $ \w -> case poke$2 addr (unbox$2 v) w of+        w' -> (# w', () #)+    sizeOf _ = Int (sizeOf$2 0#)+    alignment _ = Int (alignmentOf$2 0#)+ONCE({{+foreign import primitive "peek.$4" peek$2 :: Addr_ -> UIO $3+foreign import primitive "poke.$4" poke$2 :: Addr_ -> $3 -> UIO_+foreign import primitive "sizeOf.$4" sizeOf$2 :: Int__ -> Int__+foreign import primitive "alignmentOf.$4" alignmentOf$2 :: Int__ -> Int__+foreign import primitive "box" box$2 :: $3 -> $1+foreign import primitive "unbox" unbox$2 :: $1 -> $3+}})+}})++m4_define(INST_STORABLE,{{INST_STORABLE_X($1,$1,$2,$3)}})+m4_define(INST_STORABLE_Y,{{INST_STORABLE_YY($1,$1,$2,$3)}})++m4_divert
+ lib/jhc/Jhc/ACIO.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_JHC -fno-prelude  #-}+module Jhc.ACIO where++import Jhc.IORef+import Jhc.IO+import Jhc.Monad++newtype ACIO a = ACIO (IO a)+    deriving(Monad,Functor)++unsafeIOToACIO :: IO a -> ACIO a+unsafeIOToACIO x = ACIO x++acioToIO :: ACIO a -> IO a+acioToIO (ACIO x) = x++newIORefAC :: a -> ACIO (IORef a)+newIORefAC a = unsafeIOToACIO (newIORef a)++runOnce :: IO a -> ACIO (IO a)+runOnce action = do+    ref <- newIORefAC Nothing+    return $ do+        v <- readIORef ref+        case v of+            Just v -> return v+            Nothing -> do+                v <- action+                writeIORef ref v+                return v++{- @Extensions++# Top Level Actions++Jhc supports monadic actions declared at the top level of your module. These+can be used to do things such as initialize IORefs or allocate static data. An example+of a top level action is the following.++    import Jhc.ACIO+    import Data.IORef++    ref <- newIORefAC 0++    count = do+        modifyIORef ref (1 +)+        readIORef ref >>= print++    main = do+        count+        count+        count++Which will print 1, 2, and 3. A special monad ACIO (which stands for Affine+Central IO) is provided to restrict what may take place in top level actions.+Basically, top level actions can only consist of IO that can be omitted or+reordered without changing the meaning of a program. In practice, this means+that it does not matter whether such actions are all performed at the beginning+or are only computed once on demand.++If you need to use arbitrary IO, a utility function 'runOnce' is provided.+using it you can ensure arbitrary IO actions are run only once and the return+values shared, however you must access the value inside the IO monad, thus+ensuring program integrity. An example using a hypothetical GUI library is below.++    import Jhc.ACIO++    getWindow <- runOnce $ do+        connection <- newGUIConnection+        window <- createWindow (640,480)+        setTitle window "My Global Window"+        return window++    main = do+        w <- getWindow+        draw w "Hello!"++Note, top level global variables can be indicative of design issues. In+general, they should only be used when necessary to interface with an external+library, opaque uses inside a library where the shared state can not be+externally observed, or inside your Main program as design dictates.++-}
+ lib/jhc/Jhc/Addr.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-values -fm4 #-}+module Jhc.Addr(+    Ptr(..),+    FunPtr(..),+    nullPtr,+    nullFunPtr,+    castPtr,+    plusPtr,+    minusPtr+    ) where++import Jhc.Basics+import Jhc.Int+import Jhc.Order+import Jhc.Type.Ptr++m4_include(Jhc/Order.m4)++nullPtr :: Ptr a+nullFunPtr :: FunPtr a+nullPtr = Ptr 0#+nullFunPtr = FunPtr 0#++INST_EQORDER((Ptr a),Ptr,Addr_,U)+INST_EQORDER((FunPtr a),FunPtr,FunAddr_,U)++{-# INLINE plusPtr #-}+plusPtr :: Ptr a -> Int -> Ptr a+plusPtr (Ptr addr) off = case unboxInt off of+    off_ -> Ptr (addr `plusWordPtr` intToPtr__ off_)++{-# INLINE minusPtr #-}+minusPtr :: Ptr a -> Ptr a -> Int+minusPtr (Ptr a1) (Ptr a2) = boxInt (a1 `minusWP` a2)++foreign import primitive "Sx" intToPtr__ :: Int__ -> Addr_+foreign import primitive "I2I" ptrToInt__ :: Addr_ -> Int__++foreign import primitive "Add" plusWordPtr :: Addr_ -> Addr_ -> Addr_+foreign import primitive "Sub" minusWP :: Addr_ -> Addr_ -> Int__++castPtr :: Ptr a -> Ptr b+castPtr (Ptr addr) = Ptr addr++castFunPtr :: FunPtr a -> FunPtr b+castFunPtr (FunPtr addr) = FunPtr addr
+ lib/jhc/Jhc/Basics.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+module Jhc.Basics(module Jhc.Basics, module Jhc.Prim.Prim, module Jhc.Type.Basic, IO()) where++import Jhc.Type.Basic+import Jhc.Prim.Prim+import Jhc.Prim.IO+import Jhc.Int++------------------------+-- the basic combinators+------------------------++{-# SUPERINLINE id, const, (.), ($), ($!), flip #-}++infixr 9  .+infixr 0  $, $!, `seq`++id x = x+const x _ = x+f . g = \x -> f (g x)+f $ x = f x+f $! x = x `seq` f x+flip f x y = f y x++-- asTypeOf is a type-restricted version of const.  It is usually used+-- as an infix operator, and its typing forces its first argument+-- (which is usually overloaded) to have the same type as the second.++{-# SUPERINLINE asTypeOf #-}+asTypeOf         :: a -> a -> a+asTypeOf         =  const++{-# INLINE seq #-}+foreign import primitive seq :: a -> b -> b++--------------------+-- some tuple things+--------------------++{-# INLINE fst, snd #-}+fst (a,b) = a+snd (a,b) = b++uncurry f (x,y) = f x y+curry f x y = f (x,y)++----------------------+-- Basic list routines+----------------------++-- iterate f x returns an infinite list of repeated applications of f to x:+-- iterate f x == [x, f x, f (f x), ...]++iterate          :: (a -> a) -> a -> [a]+iterate f x      =  x : iterate f (f x)++-- repeat x is an infinite list, with x the value of every element.++repeat           :: a -> [a]+repeat x         =  xs where xs = x:xs++-- Map and append++map :: (a -> b) -> [a] -> [b]+map f xs = go xs where+    go [] = []+    go (x:xs) = f x : go xs++infixr 5  ++++(++) :: [a] -> [a] -> [a]+[]     ++ ys = ys+(x:xs) ++ ys = x : (xs ++ ys)++foldl            :: (a -> b -> a) -> a -> [b] -> a+foldl f z []     =  z+foldl f z (x:xs) =  foldl f (f z x) xs++scanl            :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q xs     =  q : (case xs of+                            []   -> []+                            x:xs -> scanl f (f q x) xs)++reverse          :: [a] -> [a]+--reverse          =  foldl (flip (:)) []+reverse l =  rev l [] where+    rev []     a = a+    rev (x:xs) a = rev xs (x:a)++-- zip takes two lists and returns a list of corresponding pairs.  If one+-- input list is short, excess elements of the longer list are discarded.+-- zip3 takes three lists and returns a list of triples.  Zips for larger+-- tuples are in the List library++zip :: [a] -> [b] -> [(a,b)]+zip (a:as) (b:bs) = (a,b) : zip as bs+zip _      _      = []++-- The zipWith family generalises the zip family by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, zipWith (+) is applied to two lists to produce the list+-- of corresponding sums.++zipWith          :: (a->b->c) -> [a]->[b]->[c]+zipWith z (a:as) (b:bs) =  z a b : zipWith z as bs+zipWith _ _ _    =  []++concat :: [[a]] -> [a]+concat [] = []+concat (x:xs) = case x of+    [] -> concat xs+    (y:ys) -> y:concat (ys:xs)++concatMap :: (a -> [b]) -> [a] -> [b]+concatMap f xs = g xs where+    g [] = []+    g (x:xs) = f x ++ g xs++foldr :: (a -> b -> b) -> b -> [a] -> b+foldr k z [] = z+foldr k z (x:xs) = k x (foldr k z xs)++drop :: Int -> [a] -> [a]+drop n xs = f n xs where+    f n xs | n `leq` zero =  xs+    f _ [] = []+    f n (_:xs) = f (n `minus` one) xs++foreign import primitive "Lte" leq :: Int -> Int -> Bool++foreign import primitive "error.Prelude.undefined" undefined :: a++unsafeChr :: Int -> Char+unsafeChr = chr++{-+ord :: Char -> Int+ord (Char (Char_ c)) = boxInt c++chr :: Int -> Char+chr i = Char (Char_ (unboxInt i))++foreign import primitive "ULte" bits32ULte  :: Bits32_ -> Bits32_ -> Bool__+foreign import primitive "error.Prelude.chr: value out of range" chr_error :: a++chr :: Int -> Char+chr i = case unboxInt i of+    i' -> case i' `bits32ULTE` 0x10FFFF# of+        1# -> Char i'+        0# -> chr_error++unsafeChr :: Int -> Char+unsafeChr i = Char (unboxInt i)+-}++foreign import primitive "B2B" ord :: Char -> Int+foreign import primitive "B2B" chr :: Int -> Char
+ lib/jhc/Jhc/Class/Num.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Jhc.Class.Num where++import Jhc.Class.Ord+import Jhc.Show+import Jhc.Type.Basic++infixl 7  *+infixl 6  +, -++class  (Eq a, Show a) => Num a  where+    (+), (-), (*)    :: a -> a -> a+    negate           :: a -> a+    abs, signum      :: a -> a+    fromInteger      :: Integer -> a+    fromInt          :: Int -> a++        -- Minimal complete definition:+        --      All, except negate or (-)+    x - y            =  x + negate y+    negate x         =  0 - x+    fromInt i = fromInteger (int2integer i)+    fromInteger x = fromInt (integer2int x)++foreign import primitive "I2I" integer2int :: Integer -> Int+foreign import primitive "I2I" int2integer :: Int -> Integer
+ lib/jhc/Jhc/Class/Ord.hs view
@@ -0,0 +1,35 @@+module Jhc.Class.Ord where++import Jhc.Prim.Prim++infix  4  ==, /=, <, <=, >=, >++class Eq a where+    (==) :: a -> a -> Bool+    (/=) :: a -> a -> Bool+    x == y = case x /= y of+        True -> False+        False -> True+    x /= y = case x == y of+        True -> False+        False -> True++class (Eq a) => Ord a where+    compare              :: a -> a -> Ordering+    (<), (<=), (>=), (>) :: a -> a -> Bool+    max, min             :: a -> a -> a++    compare x y | x == y    = EQ+                | x <= y    = LT+                | True = GT++    x <= y  = case compare x y of GT -> False; _ -> True+    x <  y  = case compare x y of LT -> True; _ -> False+    y >= x  = case compare x y of GT -> False; _ -> True+    y >  x  = case compare x y of LT -> True; _ -> False++    -- Note that (min x y, max x y) = (x,y) or (y,x)+    max x y | x <= y    =  y+            | True =  x+    min x y | x <= y    =  x+            | True =  y
+ lib/jhc/Jhc/Class/Real.hs view
@@ -0,0 +1,49 @@+module Jhc.Class.Real where++import Jhc.Basics+import Jhc.Class.Num+import Jhc.Class.Ord+import Jhc.Enum+import Jhc.Float+import Jhc.Type.Float++infixl 7  /, `quot`, `rem`, `div`, `mod`++type  Rational = Ratio Integer++class  (Num a, Ord a) => Real a  where+    toRational       ::  a -> Rational+    toDouble         ::  a -> Double+    toDouble x = rationalToDouble (toRational x)++class  (Real a, Enum a) => Integral a  where+    quot, rem        :: a -> a -> a+    div, mod         :: a -> a -> a+    quotRem, divMod  :: a -> a -> (a,a)+    toInteger        :: a -> Integer+    toInt            :: a -> Int++        -- Minimal complete definition:+        --      quotRem, toInteger+    n `quot` d       =  q  where (q,r) = quotRem n d+    n `rem` d        =  r  where (q,r) = quotRem n d+    n `div` d        =  q  where (q,r) = divMod n d+    n `mod` d        =  r  where (q,r) = divMod n d+    divMod n d       =  n `seq` d `seq` if signum r == - signum d then (q-1, r+d) else qr+                        where qr@(q,r) = quotRem n d+    quotRem n d       =  (n `quot` d, n `rem` d)+    toInteger x = toInteger (toInt x)+    toInt x = toInt (toInteger x)++class  (Num a) => Fractional a  where+    (/)              :: a -> a -> a+    recip            :: a -> a+    fromRational     :: Rational -> a+    fromDouble       :: Double   -> a++        -- Minimal complete definition:+        --      fromRational and (recip or (/))+    recip x          =  1 / x+    x / y            =  x * recip y++    --fromDouble x = fromRational (doubleToRational x)
+ lib/jhc/Jhc/Enum.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS_JHC -fm4 -fno-prelude -fffi -funboxed-values #-}+module Jhc.Enum(Enum(..),Bounded(..)) where+-- Enumeration and Bounded classes++import Jhc.Basics+import Jhc.Inst.PrimEnum()+import Jhc.Int++m4_include(Jhc/Enum.m4)++otherwise = True++class  Enum a  where+    succ, pred       :: a -> a+    toEnum           :: Int -> a+    fromEnum         :: a -> Int+    enumFrom         :: a -> [a]             -- [n..]+    enumFromThen     :: a -> a -> [a]        -- [n,n'..]+    enumFromTo       :: a -> a -> [a]        -- [n..m]+    enumFromThenTo   :: a -> a -> a -> [a]   -- [n,n'..m]++        -- Minimal complete definition:+        --      toEnum, fromEnum+--+-- NOTE: these default methods only make sense for types+--   that map injectively into Int using fromEnum+--  and toEnum.+    succ             =  toEnum . increment . fromEnum+    pred             =  toEnum . decrement . fromEnum+    enumFrom x       =  map toEnum [fromEnum x ..]+    enumFromTo x y   =  map toEnum [fromEnum x .. fromEnum y]+    enumFromThen x y =  map toEnum [fromEnum x, fromEnum y ..]+    enumFromThenTo x y z =+                        map toEnum [fromEnum x, fromEnum y .. fromEnum z]++class Bounded a  where+    minBound         :: a+    maxBound         :: a++instance Enum Int where+    succ = increment+    pred = decrement+    toEnum x = x+    fromEnum x = x++    enumFrom x  | x `seq` True  =  enumFromTo x maxBound+    enumFromThen c c' = [c, c' .. lastInt]+                      where lastInt | c' `intLt` c    = minBound+                                    | otherwise = maxBound+    enumFromTo x y = f x where+        f x | x `intGt` y = []+            | otherwise = x:f (increment x)+    enumFromThenTo x y z | y `intGte` x = f x where+        inc = y `minus` x+        f x | x `intLte` z = x:f (x `plus` inc)+            | otherwise = []+    enumFromThenTo x y z  = f x where+        inc = y `minus` x+        f x | x `intGte` z = x:f (x `plus` inc)+            | otherwise = []++foreign import primitive "box" boxBool :: Bool_ -> Bool+foreign import primitive "Gte" intGte' :: Int -> Int -> Bool_+foreign import primitive "Gt" intGt' :: Int -> Int -> Bool_+foreign import primitive "Lte" intLte' :: Int -> Int -> Bool_+foreign import primitive "Lt" intLt' :: Int -> Int -> Bool_+foreign import primitive "Lt" charLt' :: Char -> Char -> Bool_++intGte x y = boxBool (intGte' x y)+intGt x y = boxBool (intGt' x y)+intLte x y = boxBool (intLte' x y)+intLt x y = boxBool (intLt' x y)+charLt x y = boxBool (charLt' x y)++instance Enum Char where+    toEnum = chr+    fromEnum = ord+    enumFrom c        = [c .. maxBound::Char]+    enumFromThen c c' = [c, c' .. lastChar]+                      where lastChar :: Char+                            lastChar | c' `charLt` c    = minBound+                                     | otherwise = maxBound+--    enumFromTo (Char x) (Char y) = f x where+--        f x = case x `bits32UGt` y of+--            0# -> []+--            1# -> Char x:f (bits32Increment x)+--    enumFromThenTo (Char x) (Char y) (Char z) =+--        case y `bits32Sub` x of+--            inc -> let f x = case x `bits32UGte` z of+--                            1# -> Char x:f (x `bits32Add` inc)+--                            0# -> []+--             in f x++deriving instance Enum Bool+deriving instance Enum Ordering++instance Bounded Bool where+    minBound = False+    maxBound = True+instance Bounded Ordering where+    minBound = LT+    maxBound = GT+instance Bounded () where+    minBound = ()+    maxBound = ()+instance Bounded Char where+    minBound = Char 0#+    maxBound = Char 0x10ffff#++BOUNDED(Int)+BOUNDED(Integer)++--foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__+--foreign import primitive "UGte"      bits32UGte      :: Bits32_ -> Bits32_ -> Bool__+--foreign import primitive "increment" bits32Increment :: Bits32_ -> Bits32_++--foreign import primitive "Add"       bits32Add       :: Bits32_ -> Bits32_ -> Bits32_+--foreign import primitive "Sub"       bits32Sub       :: Bits32_ -> Bits32_ -> Bits32_
+ lib/jhc/Jhc/Enum.m4 view
@@ -0,0 +1,53 @@+m4_divert(-1)+m4_dnl simple macros for defining instances for classes in Jhc.Enum++m4_define(ENUMINST,{{+instance Enum $1 where+    toEnum = fromInt+    fromEnum = toInt+    succ = increment$1+    pred = decrement$1+    enumFrom c        = [c .. maxBound]+    enumFromThen c c' = last `seq` [c, c' .. last]+                      where last | c' < c    = minBound+                                 | True      = maxBound+    enumFromTo x y = f x where+        f x | x > y = []+            | True  = x:f (x + 1)+    enumFromThenTo x y z | y >= x = inc `seq` z `seq` f x where+        inc = y - x+        f x | x <= z = x:f (x + inc)+            | True   = []+    enumFromThenTo x y z  = dec `seq` z `seq` f x where+        dec = x - y+        f x | x >= z = x:f (x - dec)+            | True   = []++foreign import primitive "increment" increment$1 :: $1 -> $1+foreign import primitive "decrement" decrement$1 :: $1 -> $1++}})++m4_define(BOUNDED,{{+instance Bounded $1 where+    maxBound = maxBound$1+    minBound = minBound$1++foreign import primitive "maxBound" maxBound$1 :: $1+foreign import primitive "minBound" minBound$1 :: $1+}})++m4_define(UBOUNDED,{{+instance Bounded $1 where+    maxBound = umaxBound$1+    minBound = zero$1++foreign import primitive "umaxBound" umaxBound$1 :: $1+foreign import primitive "zero" zero$1 :: $1++}})+++++m4_divert
+ lib/jhc/Jhc/Float.hs view
@@ -0,0 +1,207 @@+{-# OPTIONS_JHC -fno-prelude -fffi -fm4 #-}+module Jhc.Float(+    Float(..),+    Double(..),+    floatToDouble,+    doubleToFloat,+    Floating(..),+    RealFrac(..),+    RealFloat(..),+    rationalToDouble+    ) where++import Jhc.Basics+import Jhc.Enum+import Jhc.Inst.Num+import Jhc.Order+import Jhc.Type.Float+import Jhc.Class.Num+import Jhc.Class.Real++infixr 8  **++foreign import primitive "F2F" floatToDouble :: Float -> Double+foreign import primitive "F2F" doubleToFloat :: Double -> Float++ -- floating point stuff++class  (Fractional a) => Floating a  where+    pi                  :: a+    exp, log, sqrt      :: a -> a+    (**), logBase       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++        -- Minimal complete definition:+        --      pi, exp, log, sin, cos, sinh, cosh+        --      asin, acos, atan+        --      asinh, acosh, atanh+    x ** y           =  exp (log x * y)+    logBase x y      =  log y / log x+    sqrt x           =  x ** (1 / 2) -- 0.5        -- TODO Doubles+    tan  x           =  sin  x / cos  x+    tanh x           =  sinh x / cosh x++-- TODO Doubles+class  (Real a, Fractional a) => RealFrac a  where+    properFraction   :: (Integral b) => a -> (b,a)+    truncate, round  :: (Integral b) => a -> b+    ceiling, floor   :: (Integral b) => a -> b++        -- Minimal complete definition:+        --      properFraction+    truncate x       =  m  where (m,_) = properFraction x++    round x          =  let (n,r) = properFraction x+                            m     = if r < 0 then n - 1 else n + 1+                          in case signum (abs r - (1 / 2)) of+                                -1 -> n+                                0  -> if n `rem` 2 == 0 then n else m+                                1  -> m++    ceiling x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFraction x++    floor x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFraction x++        -- Minimal complete definition:+        --      properFraction++    properFractionf   :: a -> (a,a)+    truncatef, roundf :: a -> a+    ceilingf, floorf  :: a -> a++    truncatef x       =  m  where (m,_) = properFractionf x+    roundf x          =  fromInteger (round x)+    ceilingf x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFractionf x+    floorf x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFractionf x++-- TODO Doubles+class  (RealFrac a, Floating a) => RealFloat a  where+    floatRadix       :: a -> Integer+    floatDigits      :: a -> Int+    floatRange       :: a -> (Int,Int)+    decodeFloat      :: a -> (Integer,Int)+    encodeFloat      :: Integer -> Int -> a+    exponent         :: a -> Int+    significand      :: a -> a+    scaleFloat       :: Int -> a -> a+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE+                     :: a -> Bool+    atan2            :: a -> a -> a++        -- Minimal complete definition:+        --      All except exponent, significand,+        --                 scaleFloat, atan2+    exponent x       =  if m == 0 then 0 else n + floatDigits x+                        where (m,n) = decodeFloat x++    significand x    =  encodeFloat m (- floatDigits x)+                        where (m,_) = decodeFloat x++    scaleFloat k x   =  encodeFloat m (n+k)+                        where (m,n) = decodeFloat x++    atan2 y x+      | x>0           =  atan (y/x)+      | x==0 && y>0   =  pi/2+      | x<0  && y>0   =  pi + atan (y/x)+      |(x<=0 && y<0)  ||+       (x<0 && isNegativeZero y) ||+       (isNegativeZero x && isNegativeZero y)+                      = -atan2 (-y) x+      | y==0 && (x<0 || isNegativeZero x)+                      =  pi    -- must be after the previous test on zero y+      | x==0 && y==0  =  y     -- must be after the other double zero tests+      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)++    decodeFloatf     :: a -> (a,Int)+    decodeFloatf x    = case decodeFloat x of+        (v,exp) -> (fromInteger v,exp)++    encodeFloatf     :: a -> Int -> a+    encodeFloatf a i = scaleFloat i a++rationalToDouble :: Rational -> Double+rationalToDouble (x:%y) = fromInteger x `divideDouble` fromInteger y++foreign import primitive "FDiv" divideDouble ::  Double -> Double -> Double++m4_define(NUMINSTANCE,+instance Num $1 where+    $1 x * $1 y = $1 (times$1 x y)+    $1 x + $1 y = $1 (plus$1 x y)+    $1 x - $1 y = $1 (minus$1 x y)+    abs ($1 x) = $1 (abs$1 x)+    negate ($1 x) = $1 (neg$1 x)+    fromInt x = fromInt$1 x+    fromInteger x = fromInteger$1 x+    signum x = case compare x 0 of+        EQ -> 0+        GT -> 1+        LT -> -1++foreign import primitive "FMul" times$1 :: $2 -> $2 -> $2+foreign import primitive "FAdd" plus$1  :: $2 -> $2 -> $2+foreign import primitive "FSub" minus$1 :: $2 -> $2 -> $2++foreign import primitive "FAbs" abs$1 :: $2 -> $2+foreign import primitive "FNeg" neg$1 :: $2 -> $2++foreign import primitive "I2F"  fromInt$1 :: Int -> $1+foreign import primitive "I2F"  fromInteger$1 :: Integer -> $1++foreign import primitive "F2I"  toInt$1 :: $1 -> Int++instance Enum $1 where+    succ = increment$1+    pred = decrement$1+    toEnum x = fromInt$1 x+    fromEnum x = toInt$1 x++    enumFrom x  | x `seq` True     =  x:enumFrom (increment$1 x)+    enumFromTo x y = f x where+        f x | x > y = []+            | otherwise = x:f (increment$1 x)+    enumFromThen x y | x `seq` y `seq` True = f x where+        z = y `fminus$1` x+        f x = x:f (x `fplus$1` z)+    enumFromThenTo x y z | y >= x = f x where+        inc = y `fminus$1` x+        f x | x <= z = x:f (x `fplus$1` inc)+            | otherwise = []+    enumFromThenTo x y z  = f x where+        inc = y `fminus$1` x+        f x | x >= z = x:f (x `fplus$1` inc)+            | otherwise = []++foreign import primitive "fincrement" increment$1 :: $1 -> $1+foreign import primitive "fdecrement" decrement$1 :: $1 -> $1+foreign import primitive "FAdd" fplus$1  :: $1 -> $1 -> $1+foreign import primitive "FSub" fminus$1 :: $1 -> $1 -> $1++instance Eq $1 where+    $1 x == $1 y = (x `eq$2` y)+    $1 x /= $1 y = (x `neq$2` y)++instance Ord $1 where+    $1 x < $1 y = (flt$2 x y)+    $1 x > $1 y = (fgt$2 x y)+    $1 x <= $1 y = (flte$2 x y)+    $1 x >= $1 y = (fgte$2 x y)++foreign import primitive "FEq" eq$2   :: $2 -> $2 -> Bool+foreign import primitive "FNEq" neq$2 :: $2 -> $2 -> Bool+foreign import primitive "FLt" flt$2  :: $2 -> $2 -> Bool+foreign import primitive "FLte" flte$2 :: $2 -> $2 -> Bool+foreign import primitive "FGt" fgt$2 :: $2 -> $2 -> Bool+foreign import primitive "FGte" fgte$2 :: $2 -> $2 -> Bool+)++NUMINSTANCE(Float,Float32_)+NUMINSTANCE(Double,Float64_)
+ lib/jhc/Jhc/ForeignPtr.hs view
@@ -0,0 +1,83 @@+module Jhc.ForeignPtr(+    ForeignPtr(),+    newPlainForeignPtr_,+    newForeignPtr_,+    mallocPlainForeignPtrAlignBytes,+    mallocForeignPtrAlignBytes,+    unsafeForeignPtrToPtr,+    castForeignPtr,+    touchForeignPtr+    ) where++import Jhc.Addr+import Jhc.IO+import Jhc.Prim.Prim+import Jhc.Prim.Rts+import Jhc.Type.Basic+import Jhc.Basics++type FinalizerPtr  a = FunPtr (Ptr a -> IO ())++-- not Addr_ because we need to make sure it is allocated in a real heap+-- location. The actual ForeignPtr heap location may contain more than the+-- single BitsPtr_ argument.+data ForeignPtr a = FP BitsPtr_++-- | This function creates a plain ForeignPtr from a Ptr, a plain foreignptr+-- may not have finalizers associated with it, hence this function may be pure.+newPlainForeignPtr_ :: Ptr a -> ForeignPtr a+newPlainForeignPtr_  (Ptr (Addr_ addr)) = FP addr++newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)+newForeignPtr_ ptr = fromUIO $ \w ->+    case gc_new_foreignptr ptr w of+        (# w', bp #) -> (# w', fromBang_ bp #)++-- | This function is similar to 'mallocForeignPtrAlignBytes', except that the+-- internally an optimised ForeignPtr representation with no finalizer is used.+-- Attempts to add a finalizer will cause the program to abort.+mallocPlainForeignPtrAlignBytes+    :: Int -- ^ alignment in bytes, must be power of 2. May be zero.+    -> Int -- ^ size to allocate in bytes.+    -> IO (ForeignPtr a)+mallocPlainForeignPtrAlignBytes align size = fromUIO $ \w ->+    case gc_malloc_foreignptr (int2word align) (int2word size) False w of+        (# w', bp #) -> (# w', fromBang_ bp #)++-- | Allocate memory of the given size and alignment that will automatically be+-- reclaimed. Any Finalizers that are attached to this will run before the+-- memory is freed.+mallocForeignPtrAlignBytes+    :: Int -- ^ alignment in bytes, must be power of 2. May be zero.+    -> Int -- ^ size to allocate in bytes.+    -> IO (ForeignPtr a)+mallocForeignPtrAlignBytes align size = fromUIO $ \w ->+    case gc_malloc_foreignptr (int2word align) (int2word size) True w of+        (# w', bp #) -> (# w', fromBang_ bp #)++foreign import safe ccall gc_malloc_foreignptr+    :: Word     -- alignment in words+    -> Word     -- size in words+    -> Bool     -- false for plain foreignptrs, true for ones with finalizers.+    -> UIO (Bang_ (ForeignPtr a))++foreign import safe ccall gc_new_foreignptr ::+    Ptr a -> UIO (Bang_ (ForeignPtr a))++foreign import unsafe ccall gc_add_foreignptr_finalizer+    :: Bang_ (ForeignPtr a)+    -> FinalizerPtr a+    -> IO ()++unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a+unsafeForeignPtrToPtr (FP x) = Ptr (Addr_ x)++touchForeignPtr :: ForeignPtr a -> IO ()+touchForeignPtr x = fromUIO_ (touch_ x)++castForeignPtr :: ForeignPtr a -> ForeignPtr b+castForeignPtr x = unsafeCoerce x++foreign import primitive touch_ :: ForeignPtr a -> UIO_+foreign import primitive "B2B" int2word :: Int -> Word+foreign import primitive unsafeCoerce :: a -> b
+ lib/jhc/Jhc/Handle.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-values #-}+module Jhc.Handle(+    Handle(..),+    IOMode(..),+    stdin,+    stdout,+    stderr,+    withHandle,+    hClose,+    hIsOpen,+    openBinaryPipe,+    openPipe,+    openBinaryFile,+    openFile+    ) where++import Foreign.C.Error+import Foreign.C.String+import Foreign.Marshal.Utils+import Foreign.Storable+import Jhc.Addr+import Jhc.Basics+import Jhc.Enum+import Jhc.Monad+import Jhc.Type.Handle+import Jhc.Order+import Jhc.Show+import Prelude.IO+import System.C.Stdio++deriving instance Eq IOMode+deriving instance Ord IOMode+deriving instance Enum IOMode+--deriving instance Bounded IOMode++instance Show IOMode where+    show ReadMode = "ReadMode"+    show WriteMode = "WriteMode"+    show AppendMode = "AppendMode"+    show ReadWriteMode = "ReadWriteMode"++instance Show Handle where+    showsPrec _ h s = handleName h ++ s++stdin, stdout, stderr :: Handle++{-# INLINE make_builtin #-}+make_builtin mode name std = Handle { handleName = name, handleFile = std, handleIOMode = mode, handleBinary = False, handleIsPipe = False }++stdin = make_builtin ReadMode "stdin" c_stdin+stdout = make_builtin WriteMode "stdout" c_stdout+stderr = make_builtin WriteMode "stderr" c_stderr++foreign import ccall "stdio.h &stdin" c_stdin :: Ptr FILE+foreign import ccall "stdio.h &stdout" c_stdout :: Ptr FILE+foreign import ccall "stdio.h &stderr" c_stderr :: Ptr FILE++withHandle h action = do+    ptr <- peek (handleFile h)+    case ptr == nullPtr of+        True -> fail $ handleName h ++ ": handle  is closed"+        False -> action ptr++hClose h = do+    ptr <- peek (handleFile h)+    case ptr == nullPtr of+        True -> return ()+        False -> do ec <- if handleIsPipe h then c_pclose ptr+                                            else c_fclose ptr+                    if ec /= 0 then fail ("hClose "++handleName h++" failed")+                               else return ()+                    poke (handleFile h) nullPtr++hIsOpen h = do+    ptr <- peek (handleFile h)+    return (ptr /= nullPtr)++throwErrnoFN     :: String	-- ^ textual description of the error location+               -> String+	       -> IO a+throwErrnoFN loc fn  = do+    errno <- getErrno+    ioError (errnoToIOError loc errno Nothing (Just fn))++openFile :: FilePath -> IOMode -> IO Handle+openFile fp m = do+    ptr <- withCString fp $ \cfp -> c_fopen cfp (Ptr (toStr m))+    if ptr == nullPtr then throwErrnoFN "openFile" fp  else do+        pptr <- new ptr+        return Handle { handleBinary = False, handleIsPipe = False, handleName = fp, handleIOMode = m, handleFile = pptr }++openPipe :: String -> IOMode -> IO Handle+openPipe c m = do+    ptr <- withCString c $ \command -> c_popen command (Ptr (toStr m))+    -- if ptr == nullPtr then throwErrnoFN "openPipe" c else do+    pptr <- new ptr+    return Handle { handleBinary = False, handleIsPipe = True, handleName = c, handleIOMode = m, handleFile = pptr }++openBinaryPipe :: String -> IOMode -> IO Handle+openBinaryPipe c m = do+    ptr <- withCString c $ \command -> c_popen command (Ptr (toStr m))+    if ptr == nullPtr then throwErrnoFN "openPipe" c  else do+        pptr <- new ptr+        return Handle { handleBinary = True, handleIsPipe = True, handleName = c, handleIOMode = m, handleFile = pptr }++openBinaryFile :: FilePath -> IOMode -> IO Handle+openBinaryFile fp m = do+    h <- openFile fp m+    return h { handleBinary = True }++toStr x = Addr_ (case x of+    ReadMode -> "r"#+    WriteMode -> "w"#+    AppendMode -> "a"#+    ReadWriteMode -> "r+"#)
+ lib/jhc/Jhc/Hole.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-tuples #-}+-- | this module provides a once-updatable value that may be used in pure code.+-- it is an _unchecked_ error to read a hole before it has been filled in.+-- filling in a hole has the effect of 'seq'ing its value immediatly so lift it in+-- a datatype if this is an issue.+--+-- this module should not be used unless you really know what you are doing.+-- incorrect usage may result in memory corruption.++module Jhc.Hole(Hole(),newHole,fillHole,readHole,errorHole) where++import Jhc.IO+import Jhc.Basics++newtype Hole a = Hole a++-- | unchecked error if readHole is evaled before fillHole has filled it in.+readHole :: Hole a -> IO a+readHole (Hole x) = strictReturn x++-- | create a new hole containing a garbage value. must not be read until it has been filled.+newHole :: IO (Hole a)+newHole = IO (\world -> newHole__ world)++-- | hole that can be written to and results discarded. never read this.+errorHole :: Hole a+errorHole = Hole undefined++-- | it is an unchecked error to fill in the same hole more than once.+fillHole :: Hole a -> a -> IO ()+fillHole r v = IO (\world -> case fillHole__ r v world of+    world' -> (# world', () #))++foreign import primitive newHole__  :: World__ -> (# World__, Hole a #)+foreign import primitive fillHole__ :: Hole a -> a -> World__ -> World__
+ lib/jhc/Jhc/IO.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_JHC -fno-prelude -funboxed-tuples -fffi #-}++module Jhc.IO(+    IO(..),+    thenIO,+    thenIO_,+    returnIO,+    fromUIO,+    fromUIO_,++    UIO(),+    UIO_(),++    World__(),+    catch,+    unIO,+    etaIO,+    dependingOn,+    fixIO,+    ioError,+    runMain,+    exitFailure,+    strictReturn,+    unsafeInterleaveIO,+    error,+    IOError(),+    userError,+    unsafePerformIO,+    unsafePerformIO'+    ) where++import Jhc.Basics+import Jhc.Prim+import Jhc.Type.Handle+import qualified Jhc.Options++unIO :: IO a -> UIO a+unIO (IO (ST x)) = x++fromUIO :: UIO a -> IO a+fromUIO x = IO (ST x)++fromUIO_ :: UIO_ -> IO ()+fromUIO_ f = IO $ ST (\w -> (# f w, () #))++-- | this ensures the world parameter is eta expanded out+{-# INLINE etaIO #-}+etaIO :: IO a -> IO a+etaIO x = fromUIO (\w -> unIO x w)++-- unsafe operations++unsafePerformIO :: IO a -> a+unsafePerformIO x = case newWorld__ x of+    world -> case unIO (errorContinuation x) world of+            (# _, a #) -> a++-- | same as unsafePerformIO, but doesn't set up error handler+unsafePerformIO' :: IO a -> a+unsafePerformIO' x = case newWorld__ x of+    world -> case (unIO x) world of+            (# _, a #) -> a++-- we have to replace the error handler because the context might have quit by the time the value is evaluated.+unsafeInterleaveIO :: IO a -> IO a+unsafeInterleaveIO action = fromUIO $ \w -> (# w , case action' w of (# _,  a #) -> a #)+    where action' = unIO $ errorContinuation action++showError :: IOError -> IO b+--showError (IOError z) = putErrLn z `thenIO_` exitFailure+showError ioe = putErrLn (ioeGetErrorString ioe) `thenIO_` exitFailure++userError x = IOError User x Nothing Nothing++errorContinuation :: IO a -> IO a+errorContinuation x = catch x showError++ioError :: IOError -> IO a+ioError e = case Jhc.Options.target of+    Jhc.Options.GhcHs -> fromUIO $+        \w -> (case raiseIO__ e w of w' -> (# w', raiseError #))+    _ -> showError e++catch :: IO a -> (IOError -> IO a) -> IO a+catch a k =  case Jhc.Options.target of+    Jhc.Options.GhcHs -> fromUIO $ \s -> catch__ (unIO a) (\ex -> unIO (k ex)) s+    _ -> a  -- no catching on other targets just yet++-- IO fixpoint operation++data FixIO a = FixIO World__ a++fixIO :: (a -> IO a) -> IO a+fixIO k = fromUIO $ \w -> let r = case k ans of+                               IO (ST z) -> case z w of+                                         (# w', r' #) -> FixIO w' r'+                              ans = case r of+                                 FixIO _ z -> z+                     in case r of+                          FixIO w' z -> (# w', z #)++-- some primitives++-- | this creates a new world object that artificially depends on its argument to avoid CSE.+foreign import primitive newWorld__ :: a -> World__+foreign import primitive "dependingOn" worldDep__ :: forall b. b -> World__ -> b++-- | this will return a value making it artificially depend on the state of the world. any uses of this value are guarenteed not to float before this point in the IO monad.+strictReturn :: a -> IO a+strictReturn a = IO $ ST $ \w -> (# w, worldDep__ a w #)++{-# INLINE runMain #-}+-- | this is wrapped around 'main' when compiling programs. it catches any exceptions and prints them to the screen and dies appropriatly.+runMain :: IO a -> World__ -> World__+runMain main w = case run w of+        (# w,  _ #) -> w+    where+    IO (ST run) = catch main $ \e ->+            putErrLn "\nUncaught Exception:" `thenIO_`+            putErrLn (ioeGetErrorString e)   `thenIO_`+            exitFailure++exitFailure :: IO a+exitFailure = IO $ ST $ \w -> exitFailure__ w++foreign import primitive exitFailure__ :: World__ -> (# World__, a #)++thenIO_ :: IO a -> IO b -> IO b+IO (ST a) `thenIO_` IO (ST b) = IO $ ST $ \w -> case a w of+    (# w', _ #) -> b w'++IO (ST a) `thenIO` b = IO $ ST $ \w -> case a w of+    (# w', v #) -> unIO (b v) w'++returnIO :: a -> IO a+returnIO x = IO $ ST (\w -> (# w, x #))++{-# NOINLINE error #-}+error s = unsafePerformIO' $+    putErrLn "error:"  `thenIO_`+    putErrLn s         `thenIO_`+    exitFailure++putErrLn :: [Char] -> IO ()+putErrLn [] = putChar '\n'+putErrLn (c:cs) = putChar c `thenIO_` putErrLn cs+putChar :: Char -> IO ()+putChar c = c_putwchar (charToInt c)++foreign import primitive "U2U" charToInt :: Char -> Int+foreign import ccall "stdio.h jhc_utf8_putchar" c_putwchar :: Int -> IO ()+foreign import primitive "error.raiseIO__" raiseError :: a
+ lib/jhc/Jhc/Inst/Enum.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-values -fm4 #-}+module Jhc.Inst.Enum() where++import Jhc.Enum+import Jhc.Class.Num+import Jhc.Class.Real+import Jhc.Class.Ord+import Jhc.IO(error)+import Jhc.Basics+import Jhc.Type.C++m4_include(Jhc/Enum.m4)++ENUMINST(Word)+ENUMINST(Word8)+ENUMINST(Word16)+ENUMINST(Word32)+ENUMINST(Word64)+ENUMINST(WordPtr)+ENUMINST(WordMax)++UBOUNDED(Word)+UBOUNDED(Word8)+UBOUNDED(Word16)+UBOUNDED(Word32)+UBOUNDED(Word64)+UBOUNDED(WordPtr)+UBOUNDED(WordMax)++ENUMINST(Int8)+ENUMINST(Int16)+ENUMINST(Int32)+ENUMINST(Int64)+ENUMINST(IntPtr)+ENUMINST(IntMax)+ENUMINST(Integer)++BOUNDED(Int8)+BOUNDED(Int16)+BOUNDED(Int32)+BOUNDED(Int64)+BOUNDED(IntPtr)+BOUNDED(IntMax)++ENUMINST(CChar)+BOUNDED(CChar)+ENUMINST(CSChar)+BOUNDED(CSChar)+ENUMINST(CUChar)+UBOUNDED(CUChar)+ENUMINST(CSize)+BOUNDED(CSize)+ENUMINST(CInt)+BOUNDED(CInt)+ENUMINST(CUInt)+UBOUNDED(CUInt)+ENUMINST(CWchar)+UBOUNDED(CWchar)++ENUMINST(CLong)+BOUNDED(CLong)+ENUMINST(CULong)+UBOUNDED(CULong)++instance Enum () where+    succ _      = error "Prelude.Enum.().succ: bad argument"+    pred _      = error "Prelude.Enum.().pred: bad argument"++    toEnum x | x == 0 = ()+             | True    = error "Prelude.Enum.().toEnum: bad argument"++    fromEnum () = 0+    enumFrom () 	= [()]+    enumFromThen () () 	= let many = ():many in many+    enumFromTo () () 	= [()]+    enumFromThenTo () () () = let many = ():many in many
+ lib/jhc/Jhc/Inst/Num.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_JHC -fm4 -fno-prelude -fffi #-}+module Jhc.Inst.Num() where++m4_include(Jhc/Num.m4)++import Jhc.Num+import Jhc.Float+import Jhc.Inst.Enum+import Prelude.Text+import Jhc.Type.C+import Jhc.Type.Basic+import Jhc.Class.Ord+import Jhc.Class.Real++m4_define(SIGNED,{{+MkNumPrim($1,I)+MkRealPrim($1,I)+MkIntegralPrim($1)+}})++m4_define(UNSIGNED,{{+MkNumPrim($1,U)+MkRealPrim($1,U)+MkIntegralUPrim($1)+}})++UNSIGNED(Word)+UNSIGNED(Word8)+UNSIGNED(Word16)+UNSIGNED(Word32)+UNSIGNED(Word64)+UNSIGNED(WordPtr)+UNSIGNED(WordMax)++SIGNED(Int)+SIGNED(Int8)+SIGNED(Int16)+SIGNED(Int32)+SIGNED(Int64)+SIGNED(IntPtr)+SIGNED(IntMax)+SIGNED(Integer)++SIGNED(CChar)+SIGNED(CSChar)+UNSIGNED(CUChar)++SIGNED(CSize)+SIGNED(CInt)+SIGNED(CLong)+UNSIGNED(CULong)+UNSIGNED(CUInt)+UNSIGNED(CWchar)
+ lib/jhc/Jhc/Inst/Order.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_JHC -fm4 -fno-prelude -fffi #-}+module Jhc.Inst.Order() where+++m4_include(Jhc/Order.m4)++import Jhc.Order+import Jhc.Prim+import Jhc.Type.Word+import Jhc.Type.C++INST_EQORDER(Int8,,Int8,)+INST_EQORDER(Int16,,Int16,)+INST_EQORDER(Int32,,Int32,)+INST_EQORDER(Int64,,Int64,)+INST_EQORDER(IntPtr,,IntPtr,)+INST_EQORDER(IntMax,,IntMax,)++INST_EQORDER(Word,,Word,U)+INST_EQORDER(Word8,,Word8,U)+INST_EQORDER(Word16,,Word16,U)+INST_EQORDER(Word32,,Word32,U)+INST_EQORDER(Word64,,Word64,U)+INST_EQORDER(WordPtr,,WordPtr,U)+INST_EQORDER(WordMax,,WordMax,U)+++INST_EQORDER(CChar,,CChar,)+INST_EQORDER(CUChar,,CUChar,)+INST_EQORDER(CSChar,,CSChar,)+INST_EQORDER(CWchar,,CWchar,)+INST_EQORDER(CInt,,CInt,)+INST_EQORDER(CUInt,,CUInt,)+INST_EQORDER(CSize,,CSize,)+INST_EQORDER(CLong,,CLong,)+INST_EQORDER(CULong,,CULong,U)
+ lib/jhc/Jhc/Inst/PrimEnum.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-values #-}++-- | helper routines for deriving(Enum) instances+-- these routines help out the compiler when+-- deriving enums.+module Jhc.Inst.PrimEnum(enum_succ,enum_pred,enum_fromTo,enum_fromThen,enum_fromThenTo,enum_toEnum,enum_from) where++import Jhc.Basics+import Jhc.Int++{-# INLINE enum_toEnum, enum_succ, enum_pred, enum_fromTo, enum_fromThen, enum_fromThenTo, enum_from #-}++enum_toEnum :: (Enum__ -> a) -> Int__ -> Int -> a+enum_toEnum box max int = case unboxInt int of+    int_ -> case int_ `bits32UGt` max of+        1# -> toEnumError+        0# -> box (intToEnum int_)++enum_succ :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> a+enum_succ box debox max e = case debox e of+    e_ -> case e_ `enumEq` max of+        0# -> box (enumInc e_)+        1# -> succError++enum_pred :: (Enum__ -> a) -> (a -> Enum__) -> a -> a+enum_pred box debox e = case debox e of+    e_ -> case e_ `enumEq` 0# of+        0# -> box (enumDec e_)+        1# -> predError++enum_from :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> [a]+enum_from box debox max x = case debox x of+    x_ -> f x_ where+        f x = case x `enumGt` max of+            0# -> box x:f (enumInc x)+            1# -> []++enum_fromTo :: (Enum__ -> a) -> (a -> Enum__) -> a -> a -> [a]+enum_fromTo box debox x y = case debox y of+    y_ -> enum_from box debox y_ x++enum_fromThen :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> a -> [a]+enum_fromThen box debox max x y = case debox x of+    x_ -> case debox y of+        y_ -> case x_ `enumGt` y_ of+            0# -> enum_fromThenToUp' box x_ y_ max+            1# -> enum_fromThenToDown' box x_ y_ 0#++enum_fromThenTo :: (Enum__ -> a) -> (a -> Enum__) -> a -> a -> a -> [a]+enum_fromThenTo box debox x y z = case debox x of+    x_ -> case debox y of+        y_ -> case debox z of+            z_ -> case x_ `enumGt` y_ of+                0# -> enum_fromThenToUp' box x_ y_ z_+                1# -> enum_fromThenToDown' box x_ y_ z_++enum_fromThenToUp' :: (Enum__ -> a) -> Enum__ -> Enum__ -> Enum__ -> [a]+enum_fromThenToUp' box x y z = case y `enumSub` x of+            inc -> let f x = case x `enumGt` z of+                            0# -> box x:f (x `enumAdd` inc)+                            1# -> []+             in f x++enum_fromThenToDown' :: (Enum__ -> a) -> Enum__ -> Enum__ -> Enum__ -> [a]+enum_fromThenToDown' box x y z = case y `enumSub` x of+            inc -> let f x = case x `enumLt` z of+                            0# -> box x:f (x `enumAdd` inc)+                            1# -> []+             in f x++ix_range :: (Enum__ -> a) -> (a -> Enum__) -> (a,a) -> [a]+ix_range box debox (x,y) = enum_fromTo box debox x y++ix_index :: (Enum__ -> a) -> (a -> Enum__) -> (a,a) -> a -> Int+ix_index box debox (x,y) v = case debox v of+    v_ -> case debox x of+        x_ -> case debox y of+            y_ -> case v_ `enumLte` x_ of+                1# -> case v_ `enumLte` y_ of+                    1# -> boxInt (enumToInt (v_ `enumSub` x_))+                    0# -> ixIndexError+                0# -> ixIndexError++ix_inRange :: (Enum__ -> a) -> (a -> Enum__) -> (a,a) -> a -> Bool+ix_inRange box debox (x,y) v = case debox v of+    v_ -> case debox x of+        x_ -> case debox y of+            y_ -> case v_ `enumGte` x_ of+                1# -> boxBool (v_ `enumLte` y_)+                0# -> boxBool 0#++foreign import primitive "box"        boxBool :: Bool__ -> Bool+foreign import primitive "Add"        enumAdd :: Enum__ -> Enum__ -> Enum__+foreign import primitive "Eq"         enumEq  :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Gt"         enumGt  :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Gte"        enumGte :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Lt"         enumLt  :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Lte"        enumLte :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Sub"        enumSub :: Enum__ -> Enum__ -> Enum__+foreign import primitive "U2U"        enumToInt :: Enum__ -> Int__+foreign import primitive "U2U"        intToEnum :: Int__ -> Enum__+foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__+foreign import primitive "decrement"  enumDec :: Enum__ -> Enum__+foreign import primitive "error.Ix.Index: out of range" ixIndexError :: a+foreign import primitive "error.pred: out of range" predError :: a+foreign import primitive "error.succ: out of range" succError :: a+foreign import primitive "error.toEnum: out of range" toEnumError :: a+foreign import primitive "increment"  enumInc :: Enum__ -> Enum__
+ lib/jhc/Jhc/Inst/Read.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_JHC -fno-prelude -fm4 #-}++module Jhc.Inst.Read() where++import Prelude.Text+import Jhc.Basics+import Jhc.Float+import Prelude.Float+import Jhc.Num+import Numeric(showSigned, showInt, readSigned, readDec, showFloat,+               readFloat, lexDigits)++-- Reading at the Integer type avoids+-- possible difficulty with minInt++m4_define(READINST,{{+instance  Read $1  where+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]+}})+++READINST(Int8)+READINST(Int16)+READINST(Int32)+READINST(Int64)+READINST(IntMax)+READINST(IntPtr)++m4_define(READWORD,{{+instance  Read $1  where+  readsPrec _ r = readDec r+}})++READWORD(Word)+READWORD(Word8)+READWORD(Word16)+READWORD(Word32)+READWORD(Word64)+READWORD(WordMax)+READWORD(WordPtr)+++instance Read () where+    readsPrec p    = readParen False+                            (\r -> [((),t) | ("(",s) <- lex r,+                                             (")",t) <- lex s ] )++instance  Read Double  where+    readsPrec p         = readSigned readDouble++instance  Read Float  where+    readsPrec p s        = [ (doubleToFloat x,y) | (x,y) <- readSigned readDouble s]
+ lib/jhc/Jhc/Inst/Show.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Jhc.Inst.Show() where++import Jhc.Basics+import Jhc.Class.Num+import Jhc.Class.Ord+import Jhc.Class.Real+import Jhc.Show+import Jhc.Type.C++-- we convert them to Word or WordMax so the showIntAtBase specialization can occur.++fromIntegral   :: (Integral a, Num b) => a -> b+fromIntegral x =  fromInteger (toInteger x)++instance Show Word where+    showsPrec _ x = showWord x++instance Show Word8 where+    showsPrec _ x = showWord (fromIntegral x :: Word)++instance Show Word16 where+    showsPrec _ x = showWord (fromIntegral x :: Word)++instance Show Word32 where+    showsPrec _ x = showWord (fromIntegral x :: Word)++instance Show Word64 where+    showsPrec _ x = showWordMax (fromIntegral x :: WordMax)++instance Show WordPtr where+    showsPrec _ x = showWordMax (fromIntegral x :: WordMax)++instance Show WordMax where+    showsPrec _ x = showWordMax x++instance Show Int where+    showsPrec p x+        | p `seq` x `seq` False = undefined+        | x < 0 = showParen (p > 6) (showChar '-' . showWord (fromIntegral $ negate x :: Word))+        | True = showWord (fromIntegral x :: Word)++instance Show Integer where+    showsPrec p x+        | p `seq` x `seq` False = undefined+        | x < 0 = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral $ negate x :: WordMax))+        | True = showWordMax (fromIntegral x :: WordMax)++instance Show Int8 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show Int16 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show Int32 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show Int64 where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)+instance Show IntPtr where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)+instance Show IntMax where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)++instance Show CSize where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)+instance Show CInt where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)+instance Show CLong where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)++instance Show CChar where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show CSChar where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show CUChar where+    showsPrec _ x = showWord (fromIntegral x :: Word)+instance Show CUInt where+    showsPrec _ x = showWord (fromIntegral x :: Word)+instance Show CULong where+    showsPrec _ x = showWordMax (fromIntegral x :: WordMax)+instance Show CWchar where+    showsPrec _ x = showWord (fromIntegral x :: Word)++-- specialized base 10 only versions of show+showWord :: Word -> String -> String+showWord w rest = w `seq` case quotRem w 10 of+    (n',d) -> n' `seq` d `seq` rest' `seq` if n' == 0 then rest' else showWord n' rest'+        where rest' = chr (fromIntegral d + ord '0') : rest++showWordMax :: WordMax -> String -> String+showWordMax w rest = w `seq` case quotRem w 10 of+    (n',d) -> n' `seq` d `seq` rest' `seq` if n' == 0 then rest' else showWordMax n' rest'+        where rest' = chr (fromIntegral d + ord '0') : rest
+ lib/jhc/Jhc/Inst/Storable.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_JHC -fm4 -fno-prelude -fffi -funboxed-tuples -funboxed-values #-}+module Jhc.Inst.Storable() where++import Jhc.Type.C+import Foreign.Storable+import Jhc.Addr+import Jhc.Basics+import Jhc.Float+import Jhc.IO++m4_include(Foreign/Storable.m4)++INST_STORABLE(Float,Float32_,fbits32)+INST_STORABLE(Double,Float64_,fbits64)++INST_STORABLE(Int,Bits32_,bits32)+INST_STORABLE(Word,Bits32_,bits32)++INST_STORABLE(Int8,Bits8_,bits8)+INST_STORABLE(Word8,Bits8_,bits8)+INST_STORABLE(Int16,Bits16_,bits16)+INST_STORABLE(Word16,Bits16_,bits16)+INST_STORABLE(Int32,Bits32_,bits32)+INST_STORABLE(Word32,Bits32_,bits32)+INST_STORABLE(Int64,Bits64_,bits64)+INST_STORABLE(Word64,Bits64_,bits64)++INST_STORABLE(IntMax,BitsMax_,bits<max>)+INST_STORABLE(WordMax,BitsMax_,bits<max>)+INST_STORABLE(IntPtr,BitsPtr_,bits<ptr>)+INST_STORABLE(WordPtr,BitsPtr_,bits<ptr>)++INST_STORABLE_Y(CChar,Bits8_,bits8)+INST_STORABLE_Y(CSChar,Bits8_,bits8)+INST_STORABLE_Y(CUChar,Bits8_,bits8)+INST_STORABLE_Y(CInt,Int_,bits<int>)+INST_STORABLE_Y(CUInt,Word_,bits<int>)+INST_STORABLE_Y(CWchar,Bits32_,bits<wchar_t>)+INST_STORABLE_Y(CSize,BitsPtr_,bits<size_t>)
+ lib/jhc/Jhc/Int.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}++-- just a few basic operations on integers to jumpstart things+module Jhc.Int(Int(),Int_(),increment,decrement,plus,minus,times,quotient,remainder,zero,one,boxInt,unboxInt) where++import Jhc.Type.Word(Int(),Int_())++foreign import primitive increment       :: Int -> Int+foreign import primitive decrement       :: Int -> Int+foreign import primitive "Add" plus      :: Int -> Int -> Int+foreign import primitive "Sub" minus     :: Int -> Int -> Int+foreign import primitive "Mul" times     :: Int -> Int -> Int+foreign import primitive "Quot" quotient :: Int -> Int -> Int+foreign import primitive "Rem" remainder :: Int -> Int -> Int+foreign import primitive zero            :: Int+foreign import primitive one             :: Int++foreign import primitive "box" boxInt :: Int_ -> Int+foreign import primitive "unbox" unboxInt :: Int -> Int_
+ lib/jhc/Jhc/JumpPoint.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+module Jhc.JumpPoint(JumpPoint(), withJumpPoint__, jumpJumpPoint__, errorJumpPoint) where++import Jhc.IO+import Jhc.Addr+import Jhc.Monad+import Jhc.Order+import Jhc.Int+import Jhc.Basics++newtype JumpPoint = JumpPoint (Ptr ())++-- | in order to be safe, the JumpPoint must not escape the handling function+withJumpPoint__ :: (JumpPoint -> Bool -> IO a) -> IO a+withJumpPoint__ action = do+    p <- _malloc jmp_buf_size+    let jp = (JumpPoint p)+    r <- jhc_setjmp jp+    r <- action jp (r /= zero)+    _free p+    return r++jumpJumpPoint__ :: JumpPoint -> IO a+jumpJumpPoint__ jp = jhc_longjmp  jp >> return (error "jumpJumpPoint__")++-- | jumping to this jumppoint will always abort the program.+foreign import ccall "&jhc_uncaught" errorJumpPoint :: JumpPoint++foreign import ccall jhc_setjmp :: JumpPoint -> IO Int+foreign import ccall jhc_longjmp :: JumpPoint -> IO ()+foreign import primitive "const.sizeof(jmp_buf)" jmp_buf_size  :: Int+foreign import ccall "malloc.h malloc" _malloc :: Int -> IO (Ptr a)+foreign import ccall "malloc.h free" _free :: Ptr a -> IO ()
+ lib/jhc/Jhc/List.hs view
@@ -0,0 +1,348 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Jhc.List where++import Jhc.Basics+import Jhc.IO(error)+import Jhc.Int+import Jhc.Order+import Jhc.String++-- | our fusion routines++build :: (forall b . (a -> b -> b) -> b -> b) -> [a]+build g = g (:) []++augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]+augment g xs = g (:) xs++{-# RULES "foldr/nil" forall k z.   foldr k z []  = z  #-}+{-# RULES "foldr/single"  forall k z x . foldr k z [x] = k x z #-}+{-# RULES "foldr/double"  forall k z x y . foldr k z [x,y] = k x (k y z) #-}+{-# RULES "foldr/triple"  forall k z a b c . foldr k z [a,b,c] = k a (k b (k c z)) #-}+{-# RULES "foldr/id"      foldr (:) [] = \x -> x  #-}+{- "foldr/app"    	[1] forall ys. foldr (:) ys = \xs -> xs ++ ys -}++{-# RULES "foldr/build" forall k z (g :: forall b . (a -> b -> b) -> b -> b) . foldr k z (build g) = g k z #-}+{-# RULES "foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .  foldr k z (augment g xs) = g k (foldr k z xs) #-}+{-# RULES "foldr/single" forall k z x. foldr k z [x] = k x z #-}+{-# RULES "augment/build" forall (g::forall b. (a->b->b) -> b -> b)+		       (h::forall b. (a->b->b) -> b -> b) .+		       augment g (build h) = build (\c n -> g c (h c n)) #-}+{-# RULES "augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .  augment g [] = build g #-}++{-# RULES "foldr/unpackString"  forall k z (addr::BitsPtr_) . foldr k z (unpackString addr) = unpackStringFoldr addr k z  #-}++-- a few pre-fusioned routines++filterIterate :: (a -> Bool) -> (a -> a) -> a -> [a]+filterIterate p f x = fi x where+    fi x | p x = x : fi (f x)+    fi x = fi (f x)++mapIterate :: (a -> b) -> (a -> a) -> a -> [b]+mapIterate f g x = fi x where+    fi x = f x : fi (g x)++filterMap :: (b -> Bool) -> (a -> b) -> [a] -> [b]+filterMap p f xs = fm xs where+    fm (x:xs) = let nx = f x in if p nx then nx:fm xs else fm xs+    fm [] = []++mapFilter :: (a -> b) -> (a -> Bool) -> [a] -> [b]+mapFilter f p xs = fm xs where+    fm (x:xs) = if p x then f x:fm xs else fm xs+    fm [] = []++{-# RULES "tail/map"      forall f xs . tail (map f xs) = map f (tail xs) #-}+{-# RULES "head/map"      forall f xs . head (map f xs) = f (head xs) #-}+{-# RULES "head/:"        forall x xs . head (x:xs) = x #-}+{-# RULES "tail/:"        forall x xs . tail (x:xs) = xs #-}++{-# RULES "filter/iterate" forall p f x . filter p (iterate f x) = filterIterate p f x  #-}+{-# RULES "map/iterate" forall f g x . map f (iterate g x) = mapIterate f g x  #-}+{-# RULES "map/filter" forall f p xs . map f (filter p xs) = mapFilter f p xs  #-}+{-# RULES "filter/map" forall f p xs . filter p (map f xs) = filterMap p f xs  #-}++-- efficient implementations of prelude routines++{-# CATALYST "and/foldr" forall . and = foldr (&&) True #-}+{-# CATALYST "or/foldr"  forall . or = foldr (||) False #-}++and, or          :: [Bool] -> Bool+and [] = True+and (False:_) = False+and (True:xs) = and xs++or [] = False+or (True:_) = True+or (False:xs) = or xs++{-# RULES "any/build"     forall p (g::forall b.(a->b->b)->b->b) .  any p (build g) = g ((||) . p) False #-}++{-# RULES "all/build"     forall p (g::forall b.(a->b->b)->b->b) .  all p (build g) = g ((&&) . p) True #-}++any, all         :: (a -> Bool) -> [a] -> Bool+any p xs = f xs where+    f [] = False+    f (x:xs) | p x = True+             | otherwise = f xs++all p xs = f xs where+    f [] = True+    f (x:xs) | not (p x) = False+             | otherwise = f xs++filter :: (a -> Bool) -> [a] -> [a]+filter p []                 = []+filter p (x:xs) | p x       = x : filter p xs+                | otherwise = filter p xs++-- elem is the list membership predicate, usually written in infix form,+-- e.g., x `elem` xs.  notElem is the negation.++infix  4  `elem`, `notElem`++-- the implementation looks a little funny, but the reason for the+-- inner loop is so that both the == function and the unboxing of the+-- argument may occur right away outside the inner loop when the list isn't+-- empty.++elem, notElem    :: (Eq a) => a -> [a] -> Bool+elem _ []	= False+elem x (y:ys)+    | x == y = True+    | otherwise = f y ys where+        f y _ | x == y = True+        f _ (y:ys) = f y ys+        f _ [] = False++{-# SPECIALIZE elem :: Char -> String -> Bool #-}+{-# SPECIALIZE elem :: Int -> [Int] -> Bool #-}+{-# RULES "elem/[]" forall c . elem c [] = False #-}+{-# RULES "elem/[_]" forall c v . elem c [v] = c == v #-}++notElem	_ []	=  True+notElem x (y:ys)+    | x == y = False+    | otherwise = f y ys where+        f y ys | x == y = False+        f _ (y:ys) = f y ys+        f _ [] = True++{-# SPECIALIZE notElem :: Char -> String -> Bool #-}+{-# SPECIALIZE notElem :: Int -> [Int] -> Bool #-}+{-# RULES "notElem/[]" forall c . notElem c [] = True #-}+{-# RULES "notElem/[_]" forall c v . notElem c [v] = c /= v #-}++infixl 9  !!++(!!)                :: [a] -> Int -> a+xs !! n | n < zero  =  error "Prelude.(!!): negative index"+	| otherwise =  sub xs n where+                sub :: [a] -> Int -> a+                sub _ n | n `seq` False = undefined+                sub []     _ = error "Prelude.(!!): index too large"+                sub (y:ys) n = if n == zero+                               then y+                               else sub ys $! (n `minus` one)++null             :: [a] -> Bool+null []          =  True+null (_:_)       =  False++-- length returns the length of a finite list as an Int.++length           :: [a] -> Int+length xs = f xs zero where+    f [] n = n+    f (_:xs) n = f xs $! n `plus` one++head             :: [a] -> a+head (x:_)       =  x+head []          =  error "Prelude.head: empty list"++tail             :: [a] -> [a]+tail (_:xs)      =  xs+tail []          =  error "Prelude.tail: empty list"++last             :: [a] -> a+last []          =  error "Prelude.last: empty list"+last (x:xs)      = last' x xs where+    last' x []     = x+    last' _ (y:ys) = last' y xs++init             :: [a] -> [a]+init []          =  error "Prelude.init: empty list"+init (x:xs)      =  init' x xs where+    init' _ [] = []+    init' y (z:zs) = y:init' z zs++{-# RULES "head/iterate"  forall f x . head (iterate f x) = x #-}+{-# RULES "head/repeat"   forall x . head (repeat x) = x #-}+{-# RULES "tail/repeat"   forall x . tail (repeat x) = repeat x #-}+{-# RULES "tail/iterate"  forall f x . tail (iterate f x) = iterate f (f x) #-}+{-# RULES "iterate/id" forall . iterate id = repeat #-}++foldl1           :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)  =  foldl f x xs+foldl1 _ []      =  error "Prelude.foldl1: empty list"++scanl1           :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)  =  scanl f x xs+scanl1 _ []      =  []++foldr1           :: (a -> a -> a) -> [a] -> a+foldr1 f [x]     =  x+foldr1 f (x:xs)  =  f x (foldr1 f xs)+foldr1 _ []      =  error "Prelude.foldr1: empty list"++scanr             :: (a -> b -> b) -> b -> [a] -> [b]+scanr f q0 []     =  [q0]+scanr f q0 (x:xs) =  f x q : qs where qs@(q:_) = scanr f q0 xs++scanr1          :: (a -> a -> a) -> [a] -> [a]+scanr1 f []     =  []+scanr1 f [x]    =  [x]+scanr1 f (x:xs) =  f x q : qs where qs@(q:_) = scanr1 f xs++{-+concatMap f = foldr ((++) . f) []+--concat xss = foldr (++) [] xss+concat xss = foldr (++) [] xss+concatMap f = foldr ((++) . f) []++and xs  = foldr (&&) True xs+sum xs = foldr (+) (0::Int) xs+(++) xs ys = augment (\c n -> foldr c n xs) ys+concat xs = foldr (++) [] xs+foldl f z xs = foldr (\b g a -> g (f a b)) id xs z++filter p xs = build (\c n -> foldr (filterFB c p) n xs)+{- RULES "filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x) #-}++{- NOINLINE filterFB #-}+filterFB c p x r | p x       = x `c` r+		 | otherwise = r++{- NOINLINE iterateFB #-}+iterate f x = build (\c _n -> iterateFB c f x)+iterateFB c f x = x `c` iterateFB c f (f x)++head (x:xs) = x+head [] = badHead++map f xs =  build (\c n -> foldr (mapFB c f) n xs)+{- NOINLINE mapFB #-}+mapFB ::  (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst+mapFB c f x ys = c (f x) ys++badHead = error "Prelude.head: empty list"++{-# RULES "head/build"   forall (g::forall b.(a->b->b)->b->b) . head (build g) = g (\x _ -> x) badHead #-}++{-# RULES "head/augment"   forall xs (g::forall b. (a->b->b) -> b -> b) .  head (augment g xs) = g (\x _ -> x) (head xs) #-}++--repeat x = build (\c _n -> repeatFB c x)+--repeatFB c x = xs where xs = x `c` xs++{-++{-# RULES forall xs n (g :: forall b . (a -> b -> b) -> b -> b) . build g !! n  = bangBang g n  #-}++bangBang :: (forall b . (a -> b -> b) -> b -> b) -> Int -> a+g `bangBang` n+    | n < 0 = error "Prelude.(!!): negative index\n"+    | otherwise = g c k  where+            sub _ n | n `seq` False = undefined+            sub []     _ = error "Prelude.(!!): index too large\n"+            sub (y:ys) n = if n == 0+                           then y+                           else sub ys $! (n - 1)++-}++(!!) :: [a] -> Int -> a+xs !! n = foldr bangFB bangCon xs n++bangCon _ = error "!! out of range"++bangFB :: a -> (Int -> a) -> Int -> a+bangFB x _xs m | m == 0 = x+bangFB _x xs m = xs $! (m - 1)++{-# INLINE bangFB #-}+{-# INLINE iterateFB #-}+{-# INLINE (!!) #-}++{-# RULES+"take"	   [~1] forall n xs . take n xs = case n of I# n# -> build (\c nil -> foldr (takeFB c nil) (takeConst nil) xs n#)+"takeList"  [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs+ #-}++{-# NOINLINE [0] takeConst #-}+-- just a version of const that doesn't get inlined too early, so we+-- can spot it in rules.  Also we need a type sig due to the unboxed Int#.+takeConst :: a -> Int# -> a+takeConst x _ = x++{-# NOINLINE [0] takeFB #-}+takeFB :: (a -> b -> c) -> c -> a -> (Int# -> b) -> Int# -> c+takeFB c n x xs m | m <=# 0#  = n+		  | otherwise = x `c` xs (m -# 1#)+  -}++-- takeWhile, applied to a predicate p and a list xs, returns the longest+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs+-- returns the remaining suffix.  span p xs is equivalent to+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.++takeWhile               :: (a -> Bool) -> [a] -> [a]+takeWhile p []          =  []+takeWhile p (x:xs)+            | p x       =  x : takeWhile p xs+            | otherwise =  []++dropWhile               :: (a -> Bool) -> [a] -> [a]+dropWhile p []          =  []+dropWhile p xs@(x:xs')+            | p x       =  dropWhile p xs'+            | otherwise =  xs++span, break             :: (a -> Bool) -> [a] -> ([a],[a])+span p []            = ([],[])+span p xs@(x:xs')+            | p x       =  (x:ys,zs)+            | otherwise =  ([],xs)+                           where (ys,zs) = span p xs'++{-# INLINE break #-}+break p                 =  span (not . p)++-- take n, applied to a list xs, returns the prefix of xs of length n,+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs+-- after the first n elements, or [] if n > length xs.  splitAt n xs+-- is equivalent to (take n xs, drop n xs).++take :: Int -> [a] -> [a]+take n xs = f n xs where+    f n _      | n <= zero =  []+    f _ []              =  []+    f n (x:xs)          =  x : f (n `minus` one) xs++-- replicate n x is a list of length n with x the value of every element+replicate        :: Int -> a -> [a]+replicate n x    = f n where+    f n | n <= zero = []+    f n = let n' = n `minus` one in n' `seq` (x:f n')++splitAt                  :: Int -> [a] -> ([a],[a])+--splitAt n xs             =  (take n xs, drop n xs)+splitAt n ls | n < zero	= ([], ls)+splitAt n ls = splitAt' n ls where+    splitAt' :: Int -> [a] -> ([a], [a])+    splitAt' z  xs | z == zero = ([], xs)+    splitAt' _  []  = ([], [])+    splitAt' m (x:xs) = case splitAt' (m `minus` one) xs of+        (xs', xs'') -> (x:xs', xs'')++{-# RULES "take/repeat"   forall n x . take n (repeat x) = replicate n x #-}
+ lib/jhc/Jhc/Maybe.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+module Jhc.Maybe(Maybe(..), module Jhc.Maybe) where++import Jhc.Basics+import Jhc.Monad+import Jhc.Num+import Jhc.Order+import Jhc.Show++instance Monad Maybe where+    return x = Just x+    Nothing >>= _ = Nothing+    Just x >>= y = y x+    fail _ = Nothing++instance Functor Maybe where+    fmap _ Nothing = Nothing+    fmap f (Just x) = Just (f x)++instance Eq a => Eq (Maybe a) where+    Nothing == Nothing = True+    Just x == Just y = x == y+    _ == _ = False++instance (Show a) => Show (Maybe a) where+    showsPrec d (Nothing) = showString "Nothing"+    showsPrec d (Just aa) = showParen (d >= 10)+	      (showString "Just" . showChar ' ' . showsPrec 10 aa)++instance Ord a => Ord (Maybe a) where+    Just x `compare` Just y = x `compare` y+    Nothing `compare` Nothing = EQ+    Nothing `compare` Just _  = LT+    Just _ `compare` Nothing  = GT++maybe :: b -> (a -> b) -> Maybe a -> b+maybe n f m = case m of+    Just x -> f x+    Nothing -> n++-- either instances+instance (Eq a,Eq b) => Eq (Either a b) where+    (Left aa) == (Left aa') = aa == aa'+    (Right aa) == (Right aa') = aa == aa'+    _ == _ = False++instance (Ord a,Ord b) => Ord (Either a b) where+    compare (Left aa) (Left aa') = compare aa aa'+    compare (Left aa) (Right aa') = LT+    compare (Right aa) (Left aa') = GT+    compare (Right aa) (Right aa') = compare aa aa'++instance (Show a,Show b) => Show (Either a b) where+    showsPrec d (Left aa) = showParen (d >= 10)+	      (showString "Left" . showChar ' ' . showsPrec 10 aa)+    showsPrec d (Right aa) = showParen (d >= 10)+	      (showString "Right" . showChar ' ' . showsPrec 10 aa)
+ lib/jhc/Jhc/Monad.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_JHC -fno-prelude -funboxed-tuples #-}+module Jhc.Monad where++import Jhc.Basics+import Jhc.IO+import Jhc.Prim.IO++-- Monadic classes++infixl 1  >>, >>=+infixr 1  =<<++infixl 4  <$++class Functor f  where+    fmap :: (a -> b) -> f a -> f b+    (<$) :: a -> f b -> f a++    a <$ fb = fmap (const a) fb++{- INLINE return, fail, (>>=), (>>) -}+class Monad m where+    (>>=)  :: m a -> (a -> m b) -> m b+    (>>)   :: m a -> m b -> m b+    return :: a -> m a+    fail   :: String -> m a++        -- Minimal complete definition:+        --      (>>=), return+    m >> k  =  m >>= \_ -> k+    fail s  = error s++{- SPECIALIZE sequence :: forall a . [IO a] -> IO [a] #-}+{- SPECIALIZE sequence_ :: forall a . [IO a] -> IO () #-}+{- SPECIALIZE mapM :: forall a b . (a -> IO b) -> [a]-> IO [b] #-}+{- SPECIALIZE mapM_ :: forall a b . (a -> IO b) -> [a]-> IO () #-}++{-# RULES "sequence/[]"   sequence [] = return [] #-}+{-# RULES "sequence_/[]"  sequence_ [] = return () #-}+{-# RULES "mapM/[]"       forall f . mapM f [] = return [] #-}+{-# RULES "mapM_/[]"      forall f . mapM_ f [] = return () #-}+{-# RULES "sequence_/++"  forall xs ys . sequence_ (xs ++ ys) = sequence_ xs >> sequence_ ys #-}+{-# RULES "mapM_/++"      forall xs ys f . mapM_ f (xs ++ ys) = mapM_ f xs >> mapM_ f ys #-}++mapM :: Monad m => (a -> m b) -> [a] -> m [b]+mapM f as = go as where+    go [] = return []+    go (a:as) = do+        a' <- f a+        as' <- go as+        return (a':as')++mapM_ :: Monad m => (a -> m b) -> [a] -> m ()+mapM_ f as = go as where+    go [] = return ()+    go (a:as) = f a >> go as++sequence :: Monad m => [m a] -> m [a]+sequence xs = f xs where+    f [] = return []+    f (x:xs) = x >>= \r -> f xs >>= \rs -> return (r:rs)++sequence_ :: Monad m => [m a] -> m ()+sequence_ xs  =  f xs where+    f [] = return ()+    f (x:xs) = x >> f xs++(=<<) :: Monad m => (a -> m b) -> m a -> m b+f =<< x =  x >>= f++instance Monad [] where+    return x = [x]+    xs >>= f = concatMap f xs+    fail _ = []++instance Functor [] where+    fmap f (x:xs) = f x : fmap f xs+    fmap f [] = []++instance Monad (ST s) where+    return x = ST $ \w -> (# w, x #)+    ST x >>= f = ST $ \w -> case x w of+        (# w, v #) -> case f v of+            ST g -> g w+    ST x >> ST y = ST $ \w -> case x w of+        (# w,  _ #) -> y w+--    fail s = ioError $ userError s++instance Monad IO where+    return x = fromUIO $ \w -> (# w, x #)+    x >> y =  x `thenIO_` y+    fail s = ioError $ userError s+    x >>= f = fromUIO $ \w -> case unIO x w of+        (# w, v #) -> unIO (f v) w++instance Functor IO where+    fmap f a = a >>= \x -> return (f x)
+ lib/jhc/Jhc/Num.hs view
@@ -0,0 +1,44 @@+module Jhc.Num(module Jhc.Num, module Jhc.Class.Num,Ratio(..)) where++import Jhc.Class.Num+import Jhc.Class.Real+import Jhc.Class.Ord+import Jhc.Type.Float+import Jhc.Basics++numerator, denominator  :: Ratio a -> a+numerator (x :% _)      =  x+denominator (_ :% y)    =  y++fromIntegral   :: (Integral a, Num b) => a -> b+fromIntegral x =  fromInteger (toInteger x)++realToFrac     :: (Real a, Fractional b) => a -> b+realToFrac x   =  fromRational (toRational x)++{-# RULES+"realToFrac/toRational"     realToFrac = toRational+"realToFrac/fromRational"   realToFrac = fromRational+"realToFrac/toDouble"       realToFrac = toDouble+"realToFrac/fromDouble"     realToFrac = fromDouble+#-}++{-# RULES+"fromIntegral/Int"          fromIntegral = (id :: Int -> Int)+"fromIntegral/Integer"      fromIntegral = (id :: Integer -> Integer)+"fromIntegral/toInt"        fromIntegral = toInt+"fromIntegral/fromInt"      fromIntegral = fromInt+"fromIntegral/toInteger"    fromIntegral = toInteger+"fromIntegral/fromInteger"  fromIntegral = fromInteger+#-}++{-# INLINE subtract #-}+subtract         :: (Num a) => a -> a -> a+subtract         =  flip (-)++{-# INLINE even #-}+{-# INLINE odd #-}++even, odd        :: (Integral a) => a -> Bool+even n           =  n `rem` 2 == 0+odd  n           =  n `rem` 2 /= 0
+ lib/jhc/Jhc/Num.m4 view
@@ -0,0 +1,67 @@+m4_divert(-1)+m4_dnl simple macros for defining instances for classes in Jhc.Enum+++m4_define(MkNumPrim,{{+instance Num $1 where+    (+) = add$1+    (-) = sub$1+    (*) = mul$1+    negate = negate$1+    abs x = if x < 0 then negate$1 x else x+    signum x = if x == 0 then x else (if x > 0 then one$1 else negate one$1)+    fromInteger = fromInteger$1+    fromInt     = fromInt$1++foreign import primitive "$2{{}}2$2" fromInt$1 :: Int -> $1+foreign import primitive "$2{{}}2$2" fromInteger$1 :: Integer -> $1++foreign import primitive "one" one$1    :: $1+foreign import primitive "Add" add$1    :: $1 -> $1 -> $1+foreign import primitive "Sub" sub$1    :: $1 -> $1 -> $1+foreign import primitive "Mul" mul$1    :: $1 -> $1 -> $1+foreign import primitive "Neg" negate$1 :: $1 -> $1+}})++m4_define(MkRealPrim,{{+instance Real $1 where+    toRational x = toInteger x :% 1+    toDouble x   =  toDouble$1 x++foreign import primitive "$2{{}}2F" toDouble$1 :: $1 -> Double+}})++m4_define(MkIntegralPrim,{{+instance Integral $1 where+--    div = div$1+    quot = quot$1+--    mod = mod$1+    rem = rem$1+    toInt = toInt$1+    toInteger = toInteger$1++foreign import primitive "I2I" toInt$1 :: $1 -> Int+foreign import primitive "I2I" toInteger$1 :: $1 -> Integer+--foreign import primitive "Div" div$1   :: $1 -> $1 -> $1+foreign import primitive "Quot" quot$1 :: $1 -> $1 -> $1+--foreign import primitive "Mod" mod$1   :: $1 -> $1 -> $1+foreign import primitive "Rem" rem$1   :: $1 -> $1 -> $1+}})++m4_define(MkIntegralUPrim,{{+instance Integral $1 where+    div   = udiv$1+    quot  = udiv$1+    mod   = umod$1+    rem   = umod$1+    toInt = toInt$1+    toInteger = toInteger$1++foreign import primitive "U2U" toInt$1 :: $1 -> Int+foreign import primitive "U2U" toInteger$1 :: $1 -> Integer+foreign import primitive "UDiv" udiv$1   :: $1 -> $1 -> $1+foreign import primitive "UMod" umod$1   :: $1 -> $1 -> $1+}})+++m4_divert
+ lib/jhc/Jhc/Numeric.hs view
@@ -0,0 +1,41 @@+module Jhc.Numeric where++import Jhc.IO+import Jhc.Num+import Jhc.Type.Basic+import Jhc.Order+import Jhc.Type.Float+import Jhc.Class.Real++infixr 8  ^, ^^++{-# SPECIALIZE gcd :: Int -> Int -> Int #-}+{-# SPECIALIZE gcd :: Integer -> Integer -> Integer #-}+gcd              :: (Integral a) => a -> a -> a+gcd 0 0          =  error "Prelude.gcd: gcd 0 0 is undefined"+gcd x y          =  gcd' (abs x) (abs y)+                    where gcd' x 0  =  x+                          gcd' x y  =  gcd' y (x `rem` y)++{-# SPECIALIZE lcm :: Int -> Int -> Int #-}+{-# SPECIALIZE lcm :: Integer -> Integer -> Integer #-}+lcm              :: (Integral a) => a -> a -> a+lcm _ 0          =  0+lcm 0 _          =  0+lcm x y          =  abs ((x `quot` (gcd x y)) * y)++{-# SPECIALIZE (^) :: Int -> Int -> Int #-}+{-# SPECIALIZE (^) :: Integer -> Int -> Integer #-}+{-# SPECIALIZE (^) :: Double -> Int -> Double #-}++(^)              :: (Num a, Integral b) => a -> b -> a+x ^ 0            =  1+x ^ n | n > 0    =  f x (n-1) x+                    where f _ 0 y = y+                          f x n y = g x n  where+                                    g x n | even n  = g (x*x) (n `quot` 2)+                                          | True = f x (n-1) (x*y)+_ ^ _            = error "Prelude.^: negative exponent"++(^^)             :: (Fractional a, Integral b) => a -> b -> a+x ^^ n           =  if n >= 0 then x^n else recip (x^(-n))
+ lib/jhc/Jhc/Options.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_JHC -fno-prelude -fffi -fcpp -funboxed-values #-}+{-# LANGUAGE CPP #-}++module Jhc.Options(+#ifdef __JHC__+    isWindows,+    isPosix,+    target,+    isBigEndian,+    isLittleEndian,+#endif+    Target(..)+    ) where++import Jhc.Basics+import Jhc.Enum+import Jhc.Order++data Target = Grin | GhcHs | DotNet | Java+    deriving(Eq,Ord,Enum)++#ifdef __JHC__++isBigEndian,isLittleEndian :: Bool+isLittleEndian = not isBigEndian++foreign import primitive "box" boxTarget :: Enum__ -> Target+foreign import primitive "box" boxBool   :: Bool_ -> Bool++target      = boxTarget (options_target      ())+isWindows   = boxBool   (options_isWindows   ())+isPosix     = boxBool   (options_isPosix     ())+isBigEndian = boxBool   (options_isBigEndian ())++foreign import primitive options_target      :: () -> Enum__+foreign import primitive options_isWindows   :: () -> Bool__+foreign import primitive options_isPosix     :: () -> Bool__+foreign import primitive options_isBigEndian :: () -> Bool__+foreign import primitive options_isConsole   :: () -> Bool__++#endif
+ lib/jhc/Jhc/Order.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_JHC -fm4 -fno-prelude -fffi #-}+module Jhc.Order(+    module Jhc.Class.Ord,+    Bool(..),+    Ordering(..),+    Eq(..),+    Ord(..),+    (&&),+    (||),+    not,+    otherwise+) where++import Jhc.Class.Ord+import Jhc.Basics++m4_include(Jhc/Order.m4)++deriving instance Eq Bool+deriving instance Ord Bool+deriving instance Eq Ordering+deriving instance Ord Ordering++instance Eq () where+    () == () = True+    () /= () = False++instance Ord () where+    () <= () = True+    () <  () = False+    () >= () = True+    () >  () = False+    max () () = ()+    min () () = ()+    compare () () = EQ++instance Eq a => Eq [a] where+    [] == [] = True+    (x:xs) == (y:ys) | x == y = xs == ys+    _ == _ = False++instance Ord a => Ord [a] where+    compare (x:xs) (y:ys) = case compare x y of+        EQ -> compare xs ys+        z -> z+    compare [] [] = EQ+    compare [] _ = LT+    compare _ [] = GT++    _ < [] = False+    [] < _ = True+    (x:xs) < (y:ys) = if x == y then xs < ys else x < y++    x > y = y < x++    x >= y = not (x < y)+    x <= y = not (y < x)++INST_EQORDER(Char,Char,Char_,U)+INST_EQORDER(Int,,Int,)+INST_EQORDER(Integer,,Integer,)++infixr 3  &&+infixr 2  ||++{-# INLINE (&&), (||), not, otherwise #-}+(&&), (||)       :: Bool -> Bool -> Bool+True  && x       =  x+False && _       =  False+True  || _       =  True+False || x       =  x++not              :: Bool -> Bool+not x = if x then False else True++otherwise        :: Bool+otherwise        =  True
+ lib/jhc/Jhc/Order.m4 view
@@ -0,0 +1,59 @@+m4_divert(-1)+m4_dnl simple macros for defining instances for classes in Jhc.Order++m4_define(BOXBOOL,{{ONCE({{+foreign import primitive "box" boxBool :: Bool_ -> Bool+}})}})++m4_define(INST_EQ,{{+instance Eq $1 where+    $2 x == $2 y =  (equals$3 x y)+    $2 x /= $2 y =  (nequals$3 x y)+ONCE({{+foreign import primitive "Eq" equals$3 :: $3 -> $3 -> Bool+foreign import primitive "NEq" nequals$3 :: $3 -> $3 -> Bool+}})+BOXBOOL()+}})++++m4_define(INST_ORDER,{{+instance Ord $1 where+    $2 x < $2 y =  (lt$4$3 x y)+    $2 x > $2 y =  (gt$4$3 x y)+    $2 x <= $2 y =  (lte$4$3 x y)+    $2 x >= $2 y =  (gte$4$3 x y)+ONCE({{+foreign import primitive "$4Lt" lt$4$3   :: $3 -> $3 -> Bool+foreign import primitive "$4Lte" lte$4$3 :: $3 -> $3 -> Bool+foreign import primitive "$4Gt" gt$4$3   :: $3 -> $3 -> Bool+foreign import primitive "$4Gte" gte$4$3 :: $3 -> $3 -> Bool+}})+BOXBOOL()+}})++m4_define(INST_EQORDER,{{INST_EQ($1,$2,$3)INST_ORDER($1,$2,$3,$4)}})++m4_define(BOUNDED,{{+instance Bounded $1 where+    maxBound = maxBound$1+    minBound = minBound$1++foreign import primitive "maxBound" maxBound$1 :: $1+foreign import primitive "minBound" minBound$1 :: $1++}})++m4_define(UBOUNDED,{{+instance Bounded $1 where+    maxBound = umaxBound$1+    minBound = zero$1++foreign import primitive "umaxBound" umaxBound$1 :: $1+foreign import primitive "zero" zero$1 :: $1++}})+++m4_divert
+ lib/jhc/Jhc/Prim.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE UnboxedTuples, ForeignFunctionInterface, NoImplicitPrelude #-}+module Jhc.Prim(module Jhc.Prim.Bits, module Jhc.Prim, module Jhc.Prim.Prim, module Jhc.Prim.IO, module Jhc.Prim.Type.Basic, module Jhc.Prim.Type.Word) where++import Jhc.Prim.Bits+import Jhc.Prim.IO++-- | this is wrapped around arbitrary expressions and just evaluates them to whnf+foreign import primitive "seq" runRaw :: a -> World__ -> World__+foreign import primitive "unsafeCoerce" unsafeCoerce__ :: a -> b++-- like 'const' but creates an artificial dependency on its second argument to guide optimization.+foreign import primitive dependingOn :: a -> b -> a
+ lib/jhc/Jhc/Show.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Jhc.Show where++import Jhc.Int+import Jhc.Basics++type  ShowS    = String -> String++class  Show a  where+    showsPrec        :: Int -> a -> ShowS+    show             :: a -> String+    showList         :: [a] -> ShowS++        -- Mimimal complete definition:+        --      show or showsPrec+    showsPrec _ x s   = show x ++ s++    show x            = showsPrec zero x ""++    showList []       = showString "[]"+    showList (x:xs)   = showChar '[' . shows x . showl xs+                        where showl []     = showChar ']'+                              showl (x:xs) = showChar ',' . shows x .+                                             showl xs++shows            :: (Show a) => a -> ShowS+shows            =  showsPrec zero++{-# INLINE showChar, showString #-}+showChar         :: Char -> ShowS+showChar         =  (:)++showString       :: String -> ShowS+showString       =  (++)++showParen        :: Bool -> ShowS -> ShowS+showParen b p    =  if b then showChar '(' . p . showChar ')' else p++instance Show () where+    showsPrec _ () = showString "()"++instance (Show a, Show b) => Show (a,b)  where+    showsPrec _ (x,y) = showChar '(' . shows x . showChar ',' .+                                          shows y . showChar ')'++instance (Show a, Show b, Show c) => Show (a, b, c) where+    showsPrec _ (x,y,z) = showChar '(' . shows x . showChar ',' .+					    shows y . showChar ',' .+					    shows z . showChar ')'++instance Show a => Show [a]  where+    showsPrec p      = showList++instance Show Bool where+    showsPrec d (False) = showString "False"+    showsPrec d (True) = showString "True"++instance Show Ordering where+    showsPrec d (LT) = showString "LT"+    showsPrec d (EQ) = showString "EQ"+    showsPrec d (GT) = showString "GT"
+ lib/jhc/Jhc/String.hs view
@@ -0,0 +1,92 @@+-- module for things dealing with string constants needed by the compiler internally+{-# LANGUAGE NoImplicitPrelude, MagicHash #-}+{-# OPTIONS_JHC -fffi -funboxed-values #-}+module Jhc.String(+    eqString,+    eqUnpackedString,+    unpackStringFoldr,+    unpackString+    )where++import Jhc.Type.Basic+import Jhc.Prim.Prim++{-# VCONSTRUCTOR unpackString #-}+{-# NOINLINE unpackString #-}+unpackString :: Addr__ -> [Char]+unpackString addr = f addr where+    f addr = case constPeekByte addr of+        '\0'# -> []+        c -> (Char c:f (increment addr))++unpackStringFoldr :: Addr__ -> (Char -> b -> b) -> b -> b+unpackStringFoldr addr cons nil = f addr where+    f addr = case constPeekByte addr of+        '\0'# -> nil+        c -> (Char c `cons` f (increment addr))++{-# NOINLINE eqUnpackedString #-}+eqUnpackedString :: Addr__ -> [Char] -> Bool_+eqUnpackedString addr cs = f addr cs where+    f :: Addr__ -> [Char] -> Bool_+    f offset [] = case constPeekByte offset of '\0'# -> 1#; _ -> 0#+    f offset (Char c:cs) = case constPeekByte offset of+        '\0'# -> 0#+        uc -> case equalsChar uc c of+            0# -> 0#+            1# -> f (increment offset) cs++eqString :: [Char] -> [Char] -> Bool_+eqString [] [] = 1#+eqString (Char x:xs) (Char y:ys) = case equalsChar x y of+    0# -> 0#+    1# -> eqString xs ys+eqString _ _ = 0#++foreign import primitive increment :: Addr__ -> Addr__+foreign import primitive "Eq" equalsChar :: Char_ -> Char_ -> Bool_+foreign import primitive constPeekByte :: Addr__ -> Char_++{-+unpackFoldrString :: Addr__ -> (Char_ -> b -> b) -> b -> b+unpackFoldrString addr f e = unpack addr where+    unpack addr = case constPeekByte addr of+      '\NUL'# -> e+      ch  | ch `leChar_` '\x7F'# = ch `f` unpack (increment addr)+          | ch `leChar_` '\xDF'# = (((ch .&. '\x1f') `shiftL` 6#) .|. (constPeekByte (increment addr) .&. '\x3f')) `f` unpack (increment (increment addr))+           (chr# (((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#))) `f`+          unpack (nh +# 2#)+      | ch `leChar#` '\xEF'# =+           (chr# (((ord# ch                                  -# 0xE0#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharArray# addr (nh +# 2#)) -# 0x80#))) `f`+          unpack (nh +# 3#)+      | otherwise            =+           (chr# (((ord# ch                                  -# 0xF0#) `uncheckedIShiftL#` 18#) +#+                    ((ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharArray# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharArray# addr (nh +# 3#)) -# 0x80#))) `f`+          unpack (nh +# 4#)+      where+	ch = indexCharArray# addr nh++eqSingleChar :: Char_ -> [Char] -> Bool_+eqSingleChar ch (Char c:cs) = case equalsChar ch c of+    0# -> 0#+    1# -> case cs of+        [] -> 1#+        _ ->  0#++{-# NOINLINE eqUnpacked #-}+eqUnpacked :: Addr__ -> [Char] -> Bool_+eqUnpacked addr cs = f addr cs where+    f :: Addr__ -> [Char] -> Bool_+    f offset [] = case constPeekByte offset of '\0'# -> 1#;  _ -> 0#+    f offset (Char c:cs) = case constPeekByte offset of+        '\NUL'# -> 0#+        uc -> case equalsChar uc c of+            0# -> 0#+            1# -> f (increment offset) cs++-}
+ lib/jhc/Jhc/Text/Read.hs view
@@ -0,0 +1,202 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Jhc.Text.Read where++import Jhc.Basics+import Jhc.Int+import Jhc.List+import Jhc.Num+import Jhc.Order+import Prelude.CType+import Jhc.Class.Real++type  ReadS a  = String -> [(a,String)]++class  Read a  where+    readsPrec        :: Int -> ReadS a+    readList         :: ReadS [a]++        -- Minimal complete definition:+        --      readsPrec+    readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,+                                                    pr       <- readl s])+                       where readl  s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,u) | (x,t)    <- reads s,+                                                    (xs,u)   <- readl' t]+                             readl' s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,v) | (",",t)  <- lex s,+                                                    (x,u)    <- reads t,+                                                    (xs,v)   <- readl' u]++reads            :: (Read a) => ReadS a+reads            =  readsPrec zero++readParen        :: Bool -> ReadS a -> ReadS a+readParen b g    =  if b then mandatory else optional+                    where optional r  = g r ++ mandatory r+                          mandatory r = [(x,u) | ("(",s) <- lex r,+                                                 (x,t)   <- optional s,+                                                 (")",u) <- lex t    ]++-- This lexer is not completely faithful to the Haskell lexical syntax.+-- Current limitations:+--    Qualified names are not handled properly+--    Octal and hexidecimal numerics are not recognized as a single token+--    Comments are not treated properly++lex              :: ReadS String+lex ""           =  [("","")]+lex (c:s)+   | isSpace c   =  lex (dropWhile isSpace s)+lex ('\'':s)     =  [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,+                                         ch /= "'" ]+lex ('"':s)      =  [('"':str, t)      | (str,t) <- lexString s]+                    where+                    lexString ('"':s) = [("\"",s)]+                    lexString s = [(ch++str, u)+                                         | (ch,t)  <- lexStrItem s,+                                           (str,u) <- lexString t  ]++                    lexStrItem ('\\':('&':s)) =  [("\\&",s)]+                    lexStrItem ('\\':(c:s)) | isSpace c+                                           =  [("\\&",t) |+                                               '\\':t <-+                                                   [dropWhile isSpace s]]+                    lexStrItem s           =  lexLitChar s++lex (c:s) | isSingle c = [([c],s)]+          | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]+          | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]+          | isDigit c  = [(c:(ds++fe),t)  | (ds,s')  <- [span isDigit s],+                                            (fe,t)  <- lexFracExp s'     ]+          | otherwise  = []    -- bad character+             where+              isSingle c =  c `elem` ",;()[]{}_`"+              isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"+              isIdChar c =  isAlphaNum c || c `elem` "_'"++              lexFracExp ('.':(c:cs)) | isDigit c+                            = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),+                                               (e,u)  <- lexExp t]+              lexFracExp s  = lexExp s++              lexExp (e:s) | e `elem` "eE"+                       = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",+                                                 (ds,u) <- lexDigits t] +++                         [(e:ds,t)   | (ds,t) <- lexDigits s]+              lexExp s = [("",s)]++asciiTab :: [String]+asciiTab = --listArray ('\NUL', ' ')+           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",+            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",+            "SP"]++lexLitChar          :: ReadS String+lexLitChar ('\\':s) =  map (prefix '\\') (lexEsc s)+        where+          lexEsc :: String -> [(String,String)]+          lexEsc (c:s)     | c `elem` "abfnrtv\\\"'"  = [([c],s)]+          lexEsc ('^':(c:s)) | (c >= '@') && (c <= '_') = [(['^',c],s)]++          -- Numeric escapes+          lexEsc ('o':s)               = [prefix 'o' (span isOctDigit s)]+          lexEsc ('x':s)               = [prefix 'x' (span isHexDigit s)]+          lexEsc s@(d:_)   | isDigit d = [span isDigit s]++          -- Very crude approximation to \XYZ.+          lexEsc s@(c:_)   | isUpper c = [span isCharName s]+          lexEsc _                     = []++          isCharName c   = isUpper c || isDigit c+          prefix c (t,s) = (c:t, s)++lexLitChar (c:s)    =  [([c],s)]+lexLitChar ""       =  []++lexDigits        :: ReadS String+lexDigits        =  nonnull isDigit++nonnull          :: (Char -> Bool) -> ReadS String+nonnull p s      =  [(cs,t) | (cs@(_:_),t) <- [span p s]]++instance (Read a,Read b) => Read (Either a b) where+    readsPrec d input =+	      readParen (d > 9)+	      (\ inp ->+	       [((Left aa) , rest) | ("Left" , inp) <- lex inp ,+		(aa , rest) <- readsPrec 10 inp])+	      input+	      +++	      readParen (d > 9)+	      (\ inp ->+	       [((Right aa) , rest) | ("Right" , inp) <- lex inp ,+		(aa , rest) <- readsPrec 10 inp])+	      input++instance (Read a) => Read (Maybe a) where+    readsPrec d input =+	      (\ inp -> [((Nothing) , rest) | ("Nothing" , rest) <- lex inp])+	      input+	      +++	      readParen (d > 9)+	      (\ inp ->+	       [((Just aa) , rest) | ("Just" , inp) <- lex inp ,+		(aa , rest) <- readsPrec 10 inp])+	      input++-- readInt reads a string of digits using an arbitrary base.+-- Leading minus signs must be handled elsewhere.++{-# SPECIALIZE readInt :: Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int #-}+{-# SPECIALIZE readInt :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer #-}++readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a+readInt radix isDig digToInt s =+   [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)+          | (ds,r) <- nonnull isDig s ]++-- Unsigned readers for various bases+readDec, readOct, readHex :: (Integral a) => ReadS a+readDec = readInt 10 isDigit    digitToInt+readOct = readInt  8 isOctDigit digitToInt+readHex = readInt 16 isHexDigit digitToInt++-- Text functions+readLitChar          :: ReadS Char+readLitChar ('\\':s) =  readEsc s+readLitChar (c:s)    =  [(c,s)]++readEsc          :: ReadS Char+readEsc ('a':s)  = [('\a',s)]+readEsc ('b':s)  = [('\b',s)]+readEsc ('f':s)  = [('\f',s)]+readEsc ('n':s)  = [('\n',s)]+readEsc ('r':s)  = [('\r',s)]+readEsc ('t':s)  = [('\t',s)]+readEsc ('v':s)  = [('\v',s)]+readEsc ('\\':s) = [('\\',s)]+readEsc ('"':s)  = [('"',s)]+readEsc ('\'':s) = [('\'',s)]+readEsc ('^':(c:s)) | c >= '@' && c <= '_'+                 = [(chr (ord c - ord '@'), s)]+readEsc s@(d:_) | isDigit d+                 = [(chr n, t) | (n,t) <- readDec s]+readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]+readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]+readEsc s@(c:_) | isUpper c+                 = let table = ('\DEL', "DEL") : zip chars asciiTab+                   in case [(c,s') | (c, mne) <- table,+                                     ([],s') <- [match mne s]]+                      of (pr:_) -> [pr]+                         []     -> []+readEsc _        = []++chars = f '\NUL' where+    f x = x:f (chr $ ord x + 1)++match                         :: (Eq a) => [a] -> [a] -> ([a],[a])+match (x:xs) (y:ys) | x == y  =  match xs ys+match xs     ys               =  (xs,ys)+
+ lib/jhc/Jhc/Tuples.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_JHC -fno-prelude #-}++-- | A place to collect the tuple instances.++module Jhc.Tuples where++import Jhc.Basics+import Jhc.Show+import Jhc.Order+import Jhc.List+import Jhc.Text.Read++{- TUPGEN!++instance (#Tup Eq #t) => Eq (#Tup #t) where+    (#Tup #x) == (#Tup #y) = and [#List #x == #y]+    (#Tup #x) /= (#Tup #y) = or [#List #x /= #y]++-}++instance (Ord a, Ord b) => Ord (a,b) where+    compare (x,y) (a,b) = case compare x a of+        EQ -> compare y b+        z -> z++instance (Ord a, Ord b, Ord c) => Ord (a,b,c) where+    compare (x,y,z) (a,b,c) = case compare x a of+        EQ -> case compare y b of+            EQ -> compare z c+            z -> z+        z -> z++instance (Ord a, Ord b, Ord c, Ord d) => Ord (a,b,c,d) where+    compare (x,y,z,j) (a,b,c,d) = case compare x a of+        EQ -> case compare y b of+            EQ -> case compare z c of+                EQ -> compare j d+                z -> z+            z -> z+        z -> z++--instance (Eq a, Eq b) => Eq (a,b) where+--    (x,y) == (a,b) = x == a && y == b++instance  (Read a, Read b) => Read (a,b)  where+    readsPrec p       = readParen False+                            (\r -> [((x,y), w) | ("(",s) <- lex r,+                                                 (x,t)   <- reads s,+                                                 (",",u) <- lex t,+                                                 (y,v)   <- reads u,+                                                 (")",w) <- lex v ] )++instance  (Read a, Read b, Read c) => Read (a,b,c)  where+    readsPrec p       = readParen False+                            (\r -> [((x,y,z), w) | ("(",s) <- lex r,+                                                 (x,t)   <- reads s,+                                                 (",",u) <- lex t,+                                                 (y,v)   <- reads u,+                                                 (",",w) <- lex v,+                                                 (z,p)   <- reads w,+                                                 (")",w) <- lex p ] )++instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where+    showsPrec _ (w,x,y,z) s = (showChar '(' . shows w . showChar ',' .+                                              shows x . showChar ',' .+                                              shows y . showChar ',' .+                                              shows z . showChar ')')+                              s++instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where+    showsPrec _ (v,w,x,y,z) s = (showChar '(' . shows v . showChar ',' .+                                                shows w . showChar ',' .+                                                shows x . showChar ',' .+                                                shows y . showChar ',' .+                                                shows z . showChar ')')+                                    s++instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a, b, c, d, e, f) where+    showsPrec _ (v,w,x,y,z,a) s = (showChar '(' . shows v . showChar ',' .+                                                  shows w . showChar ',' .+                                                  shows x . showChar ',' .+                                                  shows y . showChar ',' .+                                                  shows z . showChar ',' .+                                                  shows a . showChar ')')+                                    s++-- tupgen 2++instance (Eq t1,Eq t2) => Eq (t1,t2) where+    (x1,x2) == (y1,y2) = and [x1 == y1,x2 == y2]+    (x1,x2) /= (y1,y2) = or [x1 /= y1,x2 /= y2]++-- tupgen 3++instance (Eq t1,Eq t2,Eq t3) => Eq (t1,t2,t3) where+    (x1,x2,x3) == (y1,y2,y3) = and [x1 == y1,x2 == y2,x3 == y3]+    (x1,x2,x3) /= (y1,y2,y3) = or [x1 /= y1,x2 /= y2,x3 /= y3]++-- tupgen 4++instance (Eq t1,Eq t2,Eq t3,Eq t4) => Eq (t1,t2,t3,t4) where+    (x1,x2,x3,x4) == (y1,y2,y3,y4) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4]+    (x1,x2,x3,x4) /= (y1,y2,y3,y4) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4]++-- tupgen 5++instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5) => Eq (t1,t2,t3,t4,t5) where+    (x1,x2,x3,x4,x5) == (y1,y2,y3,y4,y5) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5]+    (x1,x2,x3,x4,x5) /= (y1,y2,y3,y4,y5) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5]++-- tupgen 6++instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5,Eq t6) => Eq (t1,t2,t3,t4,t5,t6) where+    (x1,x2,x3,x4,x5,x6) == (y1,y2,y3,y4,y5,y6) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5,x6 == y6]+    (x1,x2,x3,x4,x5,x6) /= (y1,y2,y3,y4,y5,y6) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5,x6 /= y6]++-- tupgen 7++instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5,Eq t6,Eq t7) => Eq (t1,t2,t3,t4,t5,t6,t7) where+    (x1,x2,x3,x4,x5,x6,x7) == (y1,y2,y3,y4,y5,y6,y7) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5,x6 == y6,x7 == y7]+    (x1,x2,x3,x4,x5,x6,x7) /= (y1,y2,y3,y4,y5,y6,y7) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5,x6 /= y6,x7 /= y7]
+ lib/jhc/Jhc/Type/Basic.hs view
@@ -0,0 +1,19 @@+module Jhc.Type.Basic(module Jhc.Type.Basic, module Jhc.Type.Word)  where++import Jhc.Prim.Prim+import Jhc.Type.Word++type String = [Char]++data Maybe a  =  Nothing | Just a++data Either a b = Left a | Right b++data Char = Char Char_+data Integer = Integer BitsMax_++type Bool__ = Bool_+type Int__  = Bits32_+type Char__ = Bits32_+type Enum__ = Bits16_+type Addr__ = BitsPtr_
+ lib/jhc/Jhc/Type/C.hs view
@@ -0,0 +1,42 @@+module Jhc.Type.C where++import Jhc.Type.Word+import Jhc.Type.Float++-- | Haskell representation for @errno@ values.+-- The implementation is deliberately exposed, to allow users to add+-- their own definitions of 'Errno' values.+newtype Errno = Errno CInt++newtype {-# CTYPE "char" #-}           CChar    = CChar Int8+newtype {-# CTYPE "signed char" #-}    CSChar   = CSChar Int8+newtype {-# CTYPE "unsigned char" #-}  CUChar   = CUChar Word8+newtype {-# CTYPE "short" #-}          CShort   = CShort Int16+newtype {-# CTYPE "unsigned short" #-} CUShort  = CUShort Word16+newtype {-# CTYPE "int" #-}            CInt     = CInt Int+newtype {-# CTYPE "unsigned" #-}       CUInt    = CUInt Word+newtype {-# CTYPE "long" #-}           CLong    = CLong IntPtr+newtype {-# CTYPE "unsigned long" #-}  CULong   = CULong WordPtr+newtype {-# CTYPE "long long" #-}      CLLong   = CLLong IntMax+newtype {-# CTYPE "unsigned long long" #-} CULLong  = CULLong WordMax++newtype CIntMax  = CIntMax IntMax+newtype CUIntMax = CUIntMax WordMax+newtype CIntPtr  = CIntPtr IntPtr+newtype CUIntPtr = CUIntPtr WordPtr++newtype CFloat   = CFloat Float+newtype CDouble  = CDouble Double+newtype {-# CTYPE "long double" #-} CLDouble = CLDouble Double++newtype {-# CTYPE "wchar_t" #-}   CWchar   = CWchar Word32+newtype {-# CTYPE "wint_t" #-}    CWint    = CWint Int32+newtype {-# CTYPE "clock_t" #-}   CClock   = CClock IntMax+newtype {-# CTYPE "ptrdiff_t" #-} CPtrdiff = CPtrdiff IntPtr+newtype {-# CTYPE "size_t" #-}    CSize    = CSize WordPtr+newtype {-# CTYPE "time_t" #-}    CTime    = CTime IntMax++data {-# CTYPE "FILE" #-}        CFile+data {-# CTYPE "jmp_buf" #-}     CJmpBuf+data {-# CTYPE "fpos_t" #-}      CFpos+data {-# CTYPE "sigatomic_t" #-} CSigAtomic
+ lib/jhc/Jhc/Type/Float.hs view
@@ -0,0 +1,9 @@+module Jhc.Type.Float where++import Jhc.Prim.Bits++data {-# CTYPE "float" #-} Float = Float Float32_+data {-# CTYPE "double" #-} Double = Double Float64_++infixl 7 :%+data Ratio a  = !a :% !a
+ lib/jhc/Jhc/Type/Handle.hs view
@@ -0,0 +1,32 @@+module Jhc.Type.Handle where++import Jhc.Basics+import Jhc.Type.Ptr+import Jhc.Type.C++data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode++data Handle = Handle {+    handleName :: [Char],+    handleFile :: !(Ptr (Ptr CFile)),+    handleBinary :: !Bool,+    handleIsPipe :: !Bool,+    handleIOMode :: !IOMode+    }++data IOErrorType+    = AlreadyExists+    | DoesNotExist+    | AlreadyInUse+    | Full+    | EOF+    | IllegalOperation+    | Permission+    | User++data IOError = IOError {+    ioeGetErrorType :: !IOErrorType,+    ioeGetErrorString :: String,+    ioeGetHandle :: Maybe Handle,+    ioeGetFileName :: Maybe String+    }
+ lib/jhc/Jhc/Type/Ptr.hs view
@@ -0,0 +1,6 @@+module Jhc.Type.Ptr where++import Jhc.Prim.Bits++data {-# CTYPE "HsPtr" #-} Ptr a = Ptr Addr_+data {-# CTYPE "FunPtr" #-} FunPtr a = FunPtr FunAddr_
+ lib/jhc/Jhc/Type/Word.hs view
@@ -0,0 +1,24 @@+module Jhc.Type.Word(module Jhc.Type.Word, module Jhc.Prim.Bits) where++import Jhc.Prim.Bits++-- define the lifted form of the basic+-- numeric types.++data {-# CTYPE "unsigned"  #-} Word = Word Bits32_+data {-# CTYPE "uint8_t"   #-} Word8 = Word8 Bits8_+data {-# CTYPE "uint16_t"  #-} Word16 = Word16 Bits16_+data {-# CTYPE "uint32_t"  #-} Word32 = Word32 Bits32_+data {-# CTYPE "uint64_t"  #-} Word64 = Word64 Bits64_+data {-# CTYPE "uint128_t" #-} Word128 = Word128 Bits128_+data {-# CTYPE "uintptr_t" #-} WordPtr = WordPtr BitsPtr_+data {-# CTYPE "uintmax_t" #-} WordMax = WordMax BitsMax_++data {-# CTYPE "int"      #-} Int = Int Bits32_+data {-# CTYPE "int8_t"   #-} Int8 = Int8 Bits8_+data {-# CTYPE "int16_t"  #-} Int16 = Int16 Bits16_+data {-# CTYPE "int32_t"  #-} Int32 = Int32 Bits32_+data {-# CTYPE "int64_t"  #-} Int64 = Int64 Bits64_+data {-# CTYPE "int128_t" #-} Int128 = Int128 Bits128_+data {-# CTYPE "intptr_t" #-} IntPtr = IntPtr BitsPtr_+data {-# CTYPE "intmax_t" #-} IntMax = IntMax BitsMax_
+ lib/jhc/Numeric.hs view
@@ -0,0 +1,339 @@+module Numeric(fromRat,+               showSigned, showIntAtBase,+               showInt, showOct, showHex,+               readSigned, readInt,+               readDec, readOct, readHex,+               floatToDigits,+               showEFloat, showFFloat, showGFloat, showFloat,+               readFloat, lexDigits) where++import Data.Ratio  ( (%), numerator, denominator )+import Jhc.Basics+import Jhc.Enum+import Jhc.Float+import Jhc.IO+import Jhc.List+import Jhc.Num+import Jhc.Numeric+import Jhc.Order+import Jhc.Text.Read+import Prelude.CType(isDigit,isOctDigit,isHexDigit,digitToInt,intToDigit)+import Prelude.Text+import Jhc.Class.Real++-- This converts a rational to a floating.  This should be used in the+-- Fractional instances of Float and Double.++fromRat :: (RealFloat a) => Rational -> a+fromRat = error "fromRat not implemented yet"++{-+fromRat :: (RealFloat a) => Rational -> a+fromRat x =+    if x == 0 then encodeFloat 0 0              -- Handle exceptional cases+    else if x < 0 then - fromRat' (-x)          -- first.+    else fromRat' x++-- Conversion process:+-- Scale the rational number by the RealFloat base until+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).+-- Then round the rational to an Integer and encode it with the exponent+-- that we got from the scaling.+-- To speed up the scaling process we compute the log2 of the number to get+-- a first guess of the exponent.+fromRat' :: (RealFloat a) => Rational ->  a+fromRat' x = fromRat'' x undefined++fromRat'' :: (RealFloat a) => Rational -> a -> a+fromRat'' x _x = r+  where b = floatRadix r+        p = floatDigits r+        (minExp0, _) = floatRange r+        minExp = minExp0 - p            -- the real minimum exponent+        xMin = toRational (expt b (p-1))+        xMax = toRational (expt b p)+        p0 = (integerLogBase b (numerator x) -+              integerLogBase b (denominator x) - p) `max` minExp+        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1+        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)+        r = encodeFloat (round x') p' `asTypeOf` _x++-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.+scaleRat :: Rational -> Int -> Rational -> Rational ->+             Int -> Rational -> (Rational, Int)+scaleRat b minExp xMin xMax p x =+    if p <= minExp then+        (x, p)+    else if x >= xMax then+        scaleRat b minExp xMin xMax (p+1) (x/b)+    else if x < xMin  then+        scaleRat b minExp xMin xMax (p-1) (x*b)+    else+        (x, p)+        -}+-- Exponentiation with a cache for the most common numbers.+minExpt = 0::Int+maxExpt = 1100::Int+expt :: Integer -> Int -> Integer+expt base n = base^n+{-+expt base n =+    if base == 2 && n >= minExpt && n <= maxExpt then+        expts!n+    else+        base^n++expts :: Array Int Integer+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]+-}++-- Compute the (floor of the) log of i in base b.+-- Simplest way would be just divide i by b until it's smaller then b,+-- but that would be very slow!  We are just slightly more clever.+integerLogBase :: Integer -> Integer -> Int+integerLogBase b i =+     if i < b then+        0+     else+        -- Try squaring the base first to cut down the number of divisions.+        let l = 2 * integerLogBase (b*b) i+            doDiv :: Integer -> Int -> Int+            doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)+        in  doDiv (i `div` (b^l)) l++-- Misc utilities to show integers and floats+{-# SPECIALIZE showSigned :: (Int -> ShowS) -> Int -> Int -> ShowS #-}+{-# SPECIALIZE showSigned :: (Integer -> ShowS) -> Int -> Integer -> ShowS #-}++showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS+showSigned showPos p x+  | x < 0     = showParen (p > 6) (showChar '-' . showPos (negate x))+  | otherwise = showPos x++{-# INLINE showInt #-}++-- showInt, showOct, showHex are used for positive numbers only+showInt, showOct, showHex :: Integral a => a -> ShowS+showOct = showIntAtBase  8 intToDigit+showInt = showIntAtBase 10 intToDigit+showHex = showIntAtBase 16 intToDigit++{-# SPECIALIZE showIntAtBase :: Word -> (Int -> Char) -> Word -> ShowS #-}+{-# SPECIALIZE showIntAtBase :: WordMax -> (Int -> Char) -> WordMax -> ShowS #-}++showIntAtBase :: Integral a+	      => a              -- base+	      -> (Int -> Char)  -- digit to char+	      -> a              -- number to show+	      -> ShowS+showIntAtBase base intToDig n rest+  | n < 0     = error $ "Numeric.showIntAtBase: can't show negative numbers " ++ show n+  | n' == 0   = rest'+  | otherwise = showIntAtBase base intToDig n' rest'+  where+    (n',d) = quotRem n base+    rest'  = intToDig (fromIntegral d) : rest++readSigned :: (Real a) => ReadS a -> ReadS a+readSigned readPos = readParen False read'+                     where read' r  = read'' r +++                                      [(-x,t) | ("-",s) <- lex r,+                                                (x,t)   <- read'' s]+                           read'' r = [(n,s)  | (str,s) <- lex r,+                                                (n,"")  <- readPos str]++showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFloat      :: (RealFloat a) => a -> ShowS++showEFloat d x =  showString (formatRealFloat FFExponent d x)+showFFloat d x =  showString (formatRealFloat FFFixed d x)+showGFloat d x =  showString (formatRealFloat FFGeneric d x)+showFloat      =  showGFloat Nothing++-- These are the format types.  This type is not exported.++data FFFormat = FFExponent | FFFixed | FFGeneric++formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String+formatRealFloat fmt decs x+  = s+  where+    base = 10+    s = if isNaN x then+            "NaN"+        else if isInfinite x then+            if x < 0 then "-Infinity" else "Infinity"+        else if x < 0 || isNegativeZero x then+            '-' : doFmt fmt (floatToDigits (toInteger base) (-x))+        else+            doFmt fmt (floatToDigits (toInteger base) x)++    doFmt fmt (is, e)+      = let+           ds = map intToDigit is+        in+        case fmt of+          FFGeneric ->+              doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)+                    (is, e)+          FFExponent ->+            case decs of+              Nothing ->+                case ds of+                   []    -> "0.0e0"+                   [d]   -> d : ".0e" ++ show (e-1)+                   d:ds  -> d : '.' : ds ++ 'e':show (e-1)++              Just dec ->+                let dec' = max dec 1 in+                case is of+                  [] -> '0':'.':replicate dec' '0' ++ "e0"+                  _ ->+                    let (ei, is') = roundTo base (dec'+1) is+                        d:ds = map intToDigit+                                   (if ei then init is' else is')+                    in d:'.':ds  ++ "e" ++ show (e-1+fromEnum ei)++          FFFixed ->+            case decs of+               Nothing 	-- Always prints a decimal point+                 | e > 0     -> take e (ds ++ repeat '0')+                                ++ '.' : mk0 (drop e ds)+                 | otherwise -> "0." ++ mk0 (replicate (-e) '0' ++ ds)++               Just dec ->  -- Print decimal point iff dec > 0+                 let dec' = max dec 0 in+                 if e >= 0 then+                   let (ei, is') = roundTo base (dec' + e) is+                       (ls, rs)  = splitAt (e+fromEnum ei)+                                              (map intToDigit is')+                   in  mk0 ls ++ mkdot0 rs+                 else+                   let (ei, is') = roundTo base dec'+                                           (replicate (-e) 0 ++ is)+                       d : ds = map intToDigit+                                    (if ei then is' else 0:is')+                   in  d : mkdot0 ds+            where+              mk0 "" = "0"        -- Print 0.34, not .34+              mk0 s  = s++              mkdot0 "" = ""       -- Print 34, not 34.+              mkdot0 s  = '.' : s  -- when the format specifies no+			           -- digits after the decimal point++roundTo :: Int -> Int -> [Int] -> (Bool, [Int])+roundTo base d is | base `seq` d `seq` True = case f d is of+                (False, is) -> (False, is)+                (True, is) -> (True, 1 : is)+  where b2 = base `div` 2+        f n [] = (False, replicate n 0)+        f 0 (i:_) = (i >= b2, [])+        f d (i:is) =+            let (c, ds) = f (d-1) is+                i' = fromEnum c + i+            in  if i' == base then (True, 0:ds) else (False, i':ds)++--+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.+-- The version here uses a much slower logarithm estimator.+-- It should be improved.++-- This function returns a non-empty list of digits (Ints in [0..base-1])+-- and an exponent.  In general, if+--      floatToDigits r = ([a, b, ... z], e)+-- then+--      r = 0.ab..z * base^e+--++floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)++floatToDigits _ 0 = ([], 0)+floatToDigits base x =+    let (f0, e0) = decodeFloat x+        (minExp0, _) = floatRange x+        p = floatDigits x+        b = floatRadix x+        minExp = minExp0 - p            -- the real minimum exponent++        -- Haskell requires that f be adjusted so denormalized numbers+        -- will have an impossibly low exponent.  Adjust for this.+        f :: Integer+        e :: Int+        (f, e) = let n = minExp - e0+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)++        (r, s, mUp, mDn) =+           if e >= 0 then+               let be = b^e in+               if f == b^(p-1) then+                   (f*be*b*2, 2*b, be*b, b)+               else+                   (f*be*2, 2, be, be)+           else+               if e > minExp && f == b^(p-1) then+                   (f*b*2, b^(-e+1)*2, b, 1)+               else+                   (f*2, b^(-e)*2, 1, 1)+        k =+            let k0 =+                    if b==2 && base==10 then+                        -- logBase 10 2 is slightly bigger than 3/10 so+                        -- the following will err on the low side.  Ignoring+                        -- the fraction will make it err even more.+                        -- Haskell promises that p-1 <= logBase b f < p.+                        (p - 1 + e0) * 3 `div` 10+                    else+                        ceiling ((log ((fromInteger (f+1))::Double) ++                                 fromIntegral e * log (fromInteger b)) /+                                  log (fromInteger base))+                fixup n =+                    if n >= 0 then+                        if r + mUp <= expt base n * s then n else fixup (n+1)+                    else+                        if expt base (-n) * (r + mUp) <= s then n+                                                           else fixup (n+1)+            in  fixup (k0::Int)++        gen ds rn sN mUpN mDnN =+            let (dn, rn') = (rn * base) `divMod` sN+                mUpN' = mUpN * base+                mDnN' = mDnN * base+            in  case (rn' < mDnN', rn' + mUpN' > sN) of+                (True,  False) -> dn : ds+                (False, True)  -> dn+1 : ds+                (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds+                (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'+        rds =+            if k >= 0 then+                gen [] r (s * expt base k) mUp mDn+            else+                let bk = expt base (-k)+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)+    in  (map fromIntegral (reverse rds), k)++-- This floating point reader uses a less restrictive syntax for floating+-- point than the Haskell lexer.  The `.' is optional.++readFloat     :: (RealFrac a) => ReadS a+readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,+                                                       (k,t)   <- readExp s] +++                 [ (0/0, t) | ("NaN",t)      <- lex r] +++                 [ (1/0, t) | ("Infinity",t) <- lex r]+               where+                 readFix r = [(read (ds++ds'), length ds', t)+                             | (ds,d) <- lexDigits r,+                               (ds',t) <- lexFrac d ]++                 lexFrac ('.':ds) = lexDigits ds+                 lexFrac s        = [("",s)]++                 readExp (e:s) | e `elem` "eE" = readExp' s+                 readExp s                     = [(0,s)]++                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+                 readExp' ('+':s) = readDec s+                 readExp' s       = readDec s
+ lib/jhc/Prelude/CType.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Prelude.CType (+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,+    digitToInt, intToDigit,+    toUpper, toLower+    ) where++import Jhc.Inst.Order+import Jhc.Basics+import Jhc.Order+import Jhc.List+import Jhc.IO++-- Character-testing operations+isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool++isAscii c                =  c < '\x80'++isLatin1 c               =  c <= '\xff'++isControl c              =  c < ' ' || c >= '\DEL' && c <= '\x9f'++isPrint c               =  isLatin1 c && not (isControl c)++isSpace c                =  c `elem` " \t\n\r\f\v\xA0"++isUpper c                =  c >= 'A' && c <= 'Z'++isLower c                =  c >= 'a' && c <= 'z'++isAlpha c                =  isUpper c || isLower c++isDigit c                =  c >= '0' && c <= '9'++isOctDigit c             =  c >= '0' && c <= '7'++isHexDigit c             =  isDigit c || c >= 'A' && c <= 'F' ||+                                         c >= 'a' && c <= 'f'++isAlphaNum c             =  isAlpha c || isDigit c++-- Digit conversion operations+digitToInt :: Char -> Int+digitToInt c+  | isDigit c            =  ord c - ord '0'+  | c >= 'a' && c <= 'f' =  ord c - (ord 'a' + Int 10#)+  | c >= 'A' && c <= 'F' =  ord c - (ord 'A' + Int 10#)+  | otherwise            =  error "Char.digitToInt: not a digit"++intToDigit :: Int -> Char+intToDigit i = f (int2word i) where+    f w | w < (Word 10#) = chr (ord '0' + i)+        | w < (Word 16#) = chr ((ord 'a' - Int 10#) + i)+        | otherwise = error "Char.intToDigit: not a digit"++foreign import primitive "U2U" int2word :: Int -> Word+foreign import primitive "Add" (+) :: Int -> Int -> Int+foreign import primitive "Sub" (-) :: Int -> Int -> Int++-- Case-changing operations+toUpper :: Char -> Char+toUpper c | isLower c = chr $ ord c - (Int 32#)+          | otherwise = c++toLower :: Char -> Char+toLower c | isUpper c = chr $ ord c + (Int 32#)+          | otherwise = c
+ lib/jhc/Prelude/Float.hs view
@@ -0,0 +1,266 @@+{-# OPTIONS_JHC -fno-prelude -fffi -fm4  -funboxed-tuples #-}++module Prelude.Float(readDouble,doubleToDigits,doubleToRational) where++import Jhc.Basics+import Jhc.Class.Real+import Jhc.Float+import Jhc.List(length,notElem,take,elem)+import Jhc.Num+import Jhc.Numeric((^),(^^))+import Jhc.Order+import Jhc.Type.C+import Numeric+import Prelude.Text++m4_define(INST,{{++foreign import primitive "FDiv" divide$2 ::  $2 -> $2 -> $2+foreign import primitive "FPwr" exponent$2 ::  $2 -> $2 -> $2+foreign import primitive "FAtan2" atan2$1 ::  $1 -> $1 -> $1+foreign import primitive "F2I"  toInteger$1 :: $1 -> Integer+foreign import primitive "const.M_PI" c_pi$1 :: $1++instance Fractional $1 where+    $1 x / $1 y = $1 (divide$2 x y)+    fromRational x = fromInteger (numerator x) / fromInteger (denominator x)++m4_define(FI,foreign import primitive "{{$}}1"  {{$}}2$2 :: $2 -> $2)++FI(Sqrt,sqrt)+FI(Exp,exp)+FI(Log,log)+FI(Sin,sin)+FI(Cos,cos)+FI(Tan,tan)+FI(Sinh,sinh)+FI(Cosh,cosh)+FI(Tanh,tanh)+FI(Asin,asin)+FI(Acos,acos)+FI(Atan,atan)++m4_undefine({{FI}})++instance Floating $1 where+    pi = c_pi$1+    sqrt ($1 x) = $1 (sqrt$2 x)+    exp ($1 x) = $1 (exp$2 x)+    log ($1 x) = $1 (log$2 x)+    sin ($1 x) = $1 (sin$2 x)+    cos ($1 x) = $1 (cos$2 x)+    tan ($1 x) = $1 (tan$2 x)+    asin ($1 x) = $1 (asin$2 x)+    acos ($1 x) = $1 (acos$2 x)+    atan ($1 x) = $1 (atan$2 x)+    sinh ($1 x) = $1 (sinh$2 x)+    cosh ($1 x) = $1 (cosh$2 x)+    tanh ($1 x) = $1 (tanh$2 x)+    $1 x ** $1 y = $1 (exponent$2 x y)++    asinh = c_asinh$1+    acosh = c_acosh$1+    atanh = c_atanh$1++instance RealFrac $1 where+    properFraction x+      = case (decodeFloat x)      of { (m,n) ->+    	let  b = floatRadix x     in+    	if n >= 0 then+	    (fromInteger m * fromInteger b ^ n, 0.0)+    	else+	    case (quotRem m (b^(negate n))) of { (w,r) ->+	    (fromInteger w, encodeFloat r n)+	    }+        }++    truncate x = fromInteger (toInteger$1 x)+    round x = fromInteger (toInteger$1 (roundf x))+    ceiling x = fromInteger (toInteger$1 (ceilingf x))+    floor x = fromInteger (toInteger$1 (floorf x))++    properFractionf x = (c_trunc$1 x,x - c_trunc$1 x)+    truncatef x = c_trunc$1 x+    roundf x = c_nearbyint$1 x+    ceilingf x = c_ceil$1 x+    floorf x = c_floor$1 x++foreign import ccall "-lm math.h asinh$3" c_asinh$1 :: $1 -> $1+foreign import ccall "-lm math.h acosh$3" c_acosh$1 :: $1 -> $1+foreign import ccall "-lm math.h atanh$3" c_atanh$1 :: $1 -> $1+foreign import ccall "-lm math.h trunc$3" c_trunc$1 :: $1 -> $1+foreign import ccall "-lm math.h ceil$3" c_ceil$1 :: $1 -> $1+foreign import ccall "-lm math.h floor$3" c_floor$1 :: $1 -> $1+foreign import ccall "-lm math.h nearbyint$3" c_nearbyint$1 :: $1 -> $1++foreign import ccall "math.h isnan" c_isnan$3 :: $1 -> CInt+foreign import ccall "math.h isinf" c_isinfinite$3 :: $1 -> CInt+foreign import ccall "math.h signbit" c_signbit$3 :: $1 -> CInt++foreign import ccall "math.h ldexp$3"  c_ldexp$3 :: $1 -> CInt -> $1+foreign import ccall "math.h frexp$3"  c_frexp$3 :: $1 -> (# $1, CInt #)++}})++INST(Float,Float32_,f)+INST(Double,Float64_)++instance Real Float where+    toRational x	=  (m:%1)*(b:%1)^^n+			   where (m,n) = decodeFloat x+				 b     = floatRadix  x+    toDouble x = floatToDouble x++instance Real Double where+    toRational x = doubleToRational x+    toDouble x = x++instance RealFloat Float where+    floatRadix _ = 2+    floatDigits _ = 24+    floatRange _ = (-125,128)++    exponent x		= case decodeFloatf x of (_,n) -> n+    significand x	= case decodeFloatf x of (m,_) -> m++    isNaN x = c_isnanf x /= 0+    isInfinite x = c_isinfinitef x /= 0+    isDenormalized _ = False+    isNegativeZero x = x == 0 && c_signbitf x /= 0+    isIEEE _ = True++    scaleFloat k x = c_ldexpf x (fromInt k)+    decodeFloatf x = case c_frexpf x of+        (# x', exp #) -> (x', fromIntegral exp)++    encodeFloat i e = c_ldexpf (fromInteger i) (fromInt e)+    decodeFloat x = case c_frexpf x of+        (# x', exp #) -> let x'' =  c_ldexp (floatToDouble x') (fromInt $ floatDigits x) in+            (double2integer x'', fromIntegral exp  - floatDigits x)++    atan2 = atan2Float++instance RealFloat Double where+    floatRadix _ = 2+    floatDigits _ = 53+    floatRange _ = (-1021,1024)++    exponent x		= case decodeFloatf x of (_,n) -> n+    significand x	= case decodeFloatf x of (m,_) -> m++    isNaN x = c_isnan x /= 0+    isInfinite x = c_isinfinite x /= 0+    isDenormalized _ = False+    isNegativeZero x = x == 0 && c_signbit x /= 0+    isIEEE _ = True+    scaleFloat k x = c_ldexp x (fromInt k)+    decodeFloatf x = case c_frexp x of+        (# x', exp #) -> (x', fromIntegral exp)++    encodeFloat i e =  c_ldexp (integer2double i) (fromInt e)+    decodeFloat x = case c_frexp x of+        (# x', exp #) -> let x'' = c_ldexp x' (fromInt $ floatDigits x) in+            (double2integer x'', fromIntegral exp  - floatDigits x)++    atan2 = atan2Double++foreign import primitive "I2F" integer2float :: Integer -> Float+foreign import primitive "I2F" integer2double :: Integer -> Double+foreign import primitive "F2I" double2integer :: Double -> Integer++readDouble :: ReadS Double+readDouble r    = [((fromInteger n * (10^^(k-d))),t) | (n,d,s) <- readFix r,(k,t)   <- readExp s] +++                 [ (0/0, t) | ("NaN",t)      <- lex r] +++                 [ (1/0, t) | ("Infinity",t) <- lex r]+               where+                 readFix r = [(read (take 15 $ ds++ds'), length ds', t)+                             | (ds,d) <- lexDigits r,+                               (ds',t) <- lexFrac d ]++                 lexFrac ('.':ds) = lexDigits ds+                 lexFrac s        = [("",s)]++                 readExp (e:s) | e `elem` "eE" = readExp' s+                 readExp s                     = [(0,s)]++                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+                 readExp' ('+':s) = readDec s+                 readExp' s       = readDec s++doubleToDigits :: Integer -> Double -> ([Int], Int)+doubleToDigits n d | n `seq` d `seq` d == 0 = ([], 0)+doubleToDigits base' x =+    let (f0', e0) = decodeFloat x+        base, f0 :: WordMax+        base = fromInteger base'+        f0 = fromIntegral f0'+        (minExp0, _) = floatRange x+        p = floatDigits x+        b :: WordMax+        b = fromInteger $ floatRadix x+        minExp = minExp0 - p            -- the real minimum exponent++        -- Haskell requires that f be adjusted so denormalized numbers+        -- will have an impossibly low exponent.  Adjust for this.+        f :: WordMax+        e :: Int+        (f, e) = let n = minExp - e0+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)++        (r, s, mUp, mDn) =+           if e >= 0 then+               let be = b^e in+               if f == b^(p-1) then+                   (f*be*b*2, 2*b, be*b, b)+               else+                   (f*be*2, 2, be, be)+           else+               if e > minExp && f == b^(p-1) then+                   (f*b*2, b^(-e+1)*2, b, 1)+               else+                   (f*2, b^(-e)*2, 1, 1)+        k =+            let k0 =+                    if b==2 && base==10 then+                        -- logBase 10 2 is slightly bigger than 3/10 so+                        -- the following will err on the low side.  Ignoring+                        -- the fraction will make it err even more.+                        -- Haskell promises that p-1 <= logBase b f < p.+                        (p - 1 + e0) * 3 `div` 10+                    else+                        ceiling ((log ((fromIntegral (f+1))::Double) ++                                 fromIntegral e * log (fromIntegral b)) /+                                  log (fromIntegral base))+                fixup n =+                    if n >= 0 then+                        if r + mUp <= expt base n * s then n else fixup (n+1)+                    else+                        if expt base (-n) * (r + mUp) <= s then n+                                                           else fixup (n+1)+            in  fixup (k0::Int)++        gen ds rn sN mUpN mDnN | rn `seq` sN `seq` mUpN `seq` mDnN `seq` True =+            let (dn, rn') = (rn * base) `divMod` sN+                mUpN' = mUpN * base+                mDnN' = mDnN * base+            in  case (rn' < mDnN', rn' + mUpN' > sN) of+                (True,  False) -> toInt dn : ds+                (False, True)  -> toInt (dn+1) : ds+                (True,  True)  -> if rn' * 2 < sN then toInt dn : ds else toInt (dn+1) : ds+                (False, False) -> gen (toInt dn:ds) rn' sN mUpN' mDnN'+        rds,rrds :: [Int]+        rrds = reverse rds+        rds =+            if k >= 0 then+                gen [] r (s * expt base k) mUp mDn+            else+                let bk = expt base (-k)+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)+        expt :: WordMax -> Int -> WordMax+        expt base n = base^n+    in  k `seq` f `seq` e `seq` b `seq` rrds `seq` (rrds, k)++doubleToRational :: Double -> Rational+doubleToRational x  =  (m:%1)*(b:%1)^^n where+    (m,n) = decodeFloat x+    b     = floatRadix  x
+ lib/jhc/Prelude/IO.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-values #-}+module Prelude.IO(+    IO(),+    ioError,+    catch,+    runExpr,+    FilePath(),+    putStr,+    putStrLn,+    print,+    getLine,+    getContents,+    readFile,+    interact,+    writeFile,+    appendFile,+    putChar,+    runExpr,+    getChar,+    userError+    ) where++import Foreign.C.String+import Jhc.Addr+import Jhc.Basics+import Jhc.IO+import Jhc.Monad+import Jhc.Order+import Jhc.Show+import Jhc.Type.C+import System.C.Stdio+import Jhc.Prim.Wrapper++-- IO operations exported by the prelude++type FilePath = String++{-# RULES "putStr/++"      forall xs ys . putStr (xs ++ ys) = putStr xs >> putStr ys #-}++putStr     :: String -> IO ()+putStr s   =  mapM_ putChar s++putStrLn   :: String -> IO ()+putStrLn s =  do putStr s+                 putChar '\n'++print      :: Show a => a -> IO ()+print x    =  putStrLn (show x)++getLine    :: IO String+getLine    =  do c <- getChar+                 if c == '\n' then return "" else+                    do s <- getLine+                       return (c:s)++getContents :: IO String+getContents = unsafeInterleaveIO getContents' where+    getContents' = do+        ch <- c_getwchar+        if ch == -1 then return [] else  do+            xs <- unsafeInterleaveIO getContents'+            return (unsafeChr ch:xs)++readFile :: FilePath -> IO String+readFile fn = do+    file <- withCString fn $ \fnc -> c_fopen fnc (Ptr (Addr_ "r"#))+    if  (file == nullPtr) then (fail $ "Could not open file:" ++ fn) else do+        let gc = do+                ch <- c_fgetwc file+                if ch == -1 then c_fclose file >> return [] else do+                        xs <- unsafeInterleaveIO gc+                        return (unsafeChr ch:xs)+        unsafeInterleaveIO gc++-- | The 'interact' function takes a function of type @String->String@+-- as its argument.  The entire input from the standard input device is+-- passed to this function as its argument, and the resulting string is+-- output on the standard output device.++interact        ::  (String -> String) -> IO ()+interact f      =   do s <- getContents+                       putStr (f s)+{-+interact    ::  (String -> String) -> IO ()+-- The hSetBuffering ensures the expected interactive behaviour+interact f  =  do hSetBuffering stdin  NoBuffering+                  hSetBuffering stdout NoBuffering+                  s <- getContents+                  putStr (f s)++-}++writeFile'  :: FilePath -> String -> Addr_ -> IO ()+writeFile' fn s mode = do+    file <- withCString fn $ \fnc -> c_fopen fnc (Ptr mode)+    if  (file == nullPtr) then (fail $ "Could not open file: " ++ fn) else do+        mapM_ (flip c_fputwc file . ord) s+        c_fclose file+        return ()++writeFile  :: FilePath -> String -> IO ()+writeFile fn s = writeFile' fn s (Addr_ "w"#)++appendFile  :: FilePath -> String -> IO ()+appendFile fn s = writeFile' fn s (Addr_ "a"#)++putChar :: Char -> IO ()+putChar c = c_putwchar (ord c)++-- | this is wrapped around arbitrary showable expressions when used as the main entry point+runExpr :: Show a => a -> World__ -> World__+runExpr x w = runNoWrapper (print x) w++--TODO EOF == -1+getChar :: IO Char+getChar = do+    ch <- c_getwchar+    if ch == -1 then fail "End of file." else return (unsafeChr ch)++foreign import primitive "I2I" cwintToChar :: CWint -> Char+foreign import primitive "U2U" charToCWchar :: Char -> CWchar
+ lib/jhc/Prelude/Text.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS_JHC -fno-prelude #-}+module Prelude.Text (+    ReadS, ShowS,+    Read(readsPrec, readList),+    Show(showsPrec, show, showList),+    reads, shows, read, lex,+    showChar, showString, readParen, showParen,readIO,readLn,showLitChar ) where++import Jhc.Basics+import Jhc.Type.Float+import Jhc.IO+import Jhc.Monad+import Jhc.Num+import Jhc.Show+import Jhc.Text.Read+import Prelude.IO+import Prelude.CType+import Jhc.Order+import Jhc.List++import Numeric(showSigned, showInt, readSigned, readDec, showFloat,+               readFloat, lexDigits)++readLn :: Read a => IO a+readLn =  do l <- getLine+             r <- readIO l+             return r++  -- raises an exception instead of an error+readIO   :: Read a => String -> IO a+readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of+              [x] -> return x+              []  -> ioError (userError "Prelude.readIO: no parse")+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")++read             :: (Read a) => String -> a+read s           =  case [x | (x,t) <- reads s, ("","") <- lex t] of+                         [x] -> x+                         []  -> error "Prelude.read: no parse"+                         _   -> error "Prelude.read: ambiguous parse"++instance  Read Int  where+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]+        -- Reading at the Integer type avoids+        -- possible difficulty with minInt++instance  Read Integer  where+    readsPrec p         = readSigned readDec++instance  Show Float  where+    showsPrec p         = showFloat++instance  Show Double  where+    showsPrec p         = showFloat++instance  Show Char  where+    showsPrec p '\'' = showString "'\\''"+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs = showChar '"' . showl cs+                 where showl ""       = showChar '"'+                       showl ('"':cs) = showString "\\\"" . showl cs+                       showl (c:cs)   = showLitChar c . showl cs++instance  Read Char  where+    readsPrec p      = readParen False+                            (\r -> [(c,t) | ('\'':s,t)<- lex r,+                                            (c,"\'")  <- readLitChar s])++    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,+                                               (l,_)      <- readl s ])+        where readl ('"':s)      = [("",s)]+              readl ('\\':('&':s)) = readl s+              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,+                                               (cs,u) <- readl t       ]++instance  (Read a) => Read [a]  where+    readsPrec p      = readList++instance Read Bool where+    readsPrec d input =+              (\ inp -> [((False) , rest) | ("False" , rest) <- lex inp]) input+              +++              (\ inp -> [((True) , rest) | ("True" , rest) <- lex inp]) input++instance Read Ordering where+    readsPrec d input =+              (\ inp -> [((LT) , rest) | ("LT" , rest) <- lex inp]) input+              +++              (\ inp -> [((EQ) , rest) | ("EQ" , rest) <- lex inp]) input+              +++              (\ inp -> [((GT) , rest) | ("GT" , rest) <- lex inp]) input++--instance (Read a) => Read (Maybe a) where+--    readsPrec d input =+--	      (\ inp -> [((Nothing) , rest) | ("Nothing" , rest) <- lex inp])+--	      input+--	      +++--	      readParen (d > 9)+--	      (\ inp ->+--	       [((Just aa) , rest) | ("Just" , inp) <- lex inp ,+--		(aa , rest) <- readsPrec 10 inp])+--	      input++showLitChar               :: Char -> ShowS+showLitChar c | c > '\DEL' =  showChar '\\' .+                              protectEsc isDigit (shows (ord c))+showLitChar '\DEL'         =  showString "\\DEL"+showLitChar '\\'           =  showString "\\\\"+showLitChar c | c >= ' '   =  showChar c+showLitChar '\a'           =  showString "\\a"+showLitChar '\b'           =  showString "\\b"+showLitChar '\f'           =  showString "\\f"+showLitChar '\n'           =  showString "\\n"+showLitChar '\r'           =  showString "\\r"+showLitChar '\t'           =  showString "\\t"+showLitChar '\v'           =  showString "\\v"+showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")+showLitChar c              =  showString ('\\' : (asciiTab!!ord c))++protectEsc p f             = f . cont+                             where cont s@(c:_) | p c = "\\&" ++ s+                                   cont s             = s
+ lib/jhc/System/C/Stdio.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}+module System.C.Stdio where++import Jhc.Basics+import Jhc.Type.C+import Jhc.Type.Ptr++type FILE = Ptr CFile++foreign import ccall "stdio.h fopen" c_fopen               :: Ptr CChar -> Ptr CChar -> IO FILE+foreign import ccall "stdio.h popen" c_popen               :: Ptr CChar -> Ptr CChar -> IO FILE+foreign import ccall "stdio.h fclose" c_fclose             :: FILE -> IO CInt+foreign import ccall "stdio.h pclose" c_pclose             :: FILE -> IO CInt+foreign import ccall "stdio.h jhc_utf8_putchar" c_putwchar :: Int -> IO ()+foreign import ccall "wchar.h jhc_utf8_getc" c_fgetwc      :: FILE -> IO Int+foreign import ccall "wchar.h jhc_utf8_getchar" c_getwchar :: IO Int+foreign import ccall "wchar.h jhc_utf8_putc" c_fputwc      :: Int -> FILE -> IO Int+foreign import ccall "stdio.h fwrite_unlocked" c_fwrite    :: Ptr a -> CSize -> CSize -> FILE -> IO CSize+foreign import ccall "stdio.h fread_unlocked" c_fread      :: Ptr a -> CSize -> CSize -> FILE -> IO CSize+foreign import ccall "stdio.h fflush" c_fflush             :: FILE -> IO ()+foreign import ccall "stdio.h feof" c_feof                 :: FILE -> IO Int+foreign import ccall "stdio.h ftell" c_ftell               :: FILE -> IO IntMax+foreign import ccall "stdio.h fseek" c_fseek               :: FILE -> IntMax -> CInt -> IO Int+foreign import ccall "stdio.h fileno" c_fileno             :: FILE -> IO Int+foreign import primitive "const.SEEK_SET" c_SEEK_SET :: CInt+foreign import primitive "const.SEEK_CUR" c_SEEK_CUR :: CInt+foreign import primitive "const.SEEK_END" c_SEEK_END :: CInt+foreign import primitive "const._IOFBF" c__IOFBF :: CInt+foreign import primitive "const._IOLBF" c__IOLBF :: CInt+foreign import primitive "const._IONBF" c__IONBF :: CInt
+ lib/jhc/System/IO/Unsafe.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_JHC -fno-prelude #-}+module System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO) where++import Jhc.IO
+ lib/jhc/System/Mem.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_JHC -fno-prelude -fffi #-}++module System.Mem where++import Jhc.Prim.IO++foreign import ccall safe "hs_perform_gc" performGC :: IO ()
+ lib/jhc/System/Mem/StableName.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_JHC -fno-prelude -fffi -fm4   #-}+module System.Mem.StableName(StableName(),makeStableName,hashStableName) where++import Jhc.Basics+import Jhc.IO+import Jhc.Order++m4_include(Jhc/Order.m4)++data StableName a = StableName BitsPtr_++makeStableName :: a -> IO (StableName a)+makeStableName x = returnIO $ StableName (toHeapAddr x)++hashStableName :: StableName a -> Int+hashStableName (StableName a) = bitsPtrToInt (jhc_hashptr a)++foreign import primitive toHeapAddr :: a -> BitsPtr_+foreign import primitive "U2U" bitsPtrToInt :: BitsPtr_ -> Int+foreign import jhc_hashptr :: BitsPtr_ -> BitsPtr_++INST_EQORDER((StableName a),StableName,BitsPtr_,U)
+ lib/jhc/jhc.yaml view
@@ -0,0 +1,61 @@+Name: jhc+Version: 1.0+Extensions: [ ForeignFunctionInterface, NoImplicitPrelude, UnboxedTuples, UnboxedValues ]+Hs-Source-Dir: .+Options: [ --noauto, -pjhc-prim ]+Hidden-Modules:+        - Jhc.Int+        - Jhc.Inst.Enum+        - Jhc.Inst.PrimEnum+        - Jhc.Inst.Read+        - Jhc.Inst.Show+        - Jhc.Inst.Storable+Exposed-Modules:+        - Data.Ratio+        - Foreign.C.Error+        - Foreign.C.String+        - Foreign.C.Types+        - Foreign.Marshal.Alloc+        - Foreign.Marshal.Array+        - Foreign.Marshal.Utils+        - Foreign.Ptr+        - Foreign.Storable+        - Jhc.Addr+        - Jhc.Basics+        - Jhc.Enum+        - Jhc.Float+        - Jhc.Numeric+        - Jhc.Handle+        - Jhc.IO+        - Jhc.List+        - Jhc.Maybe+        - Jhc.Monad+        - Jhc.Num+        - Jhc.Options+        - Jhc.Order+        - Jhc.Prim+        - Jhc.Show+        - Jhc.String+        - Jhc.Text.Read+        - Jhc.Tuples+        - Jhc.ForeignPtr+        - Numeric+        - Prelude.CType+        - Prelude.Float+        - Prelude.IO+        - Prelude.Text+        - System.C.Stdio+        - System.IO.Unsafe+        - System.Mem+        - System.Mem.StableName+        - Jhc.Type.Basic+        - Jhc.Type.Handle+        - Jhc.Type.Ptr+        - Jhc.Type.C+        - Jhc.Type.Float+        - Jhc.Type.Word+        - Jhc.Class.Num+        - Jhc.Class.Ord+        - Jhc.Class.Real+#        - Jhc.Hole+#        - Jhc.JumpPoint
+ library_deps.make view
@@ -0,0 +1,79 @@+BUILD_EXTLIBS = perl utils/build_extlibs.prl -c $(JHCPROG)++jhc-prim-1.0.hl: lib/jhc-prim/jhc-prim.yaml lib/jhc-prim/Jhc/Prim/IO.hs lib/jhc-prim/Jhc/Prim/Prim.hs lib/jhc-prim/Jhc/Prim/Array.hs lib/jhc-prim/Jhc/Prim/Wrapper.hs \+    lib/jhc-prim/Jhc/Prim/Rts.hs lib/jhc-prim/Jhc/Prim/Bits.hs+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+jhc-1.0.hl: lib/jhc/jhc.yaml lib/jhc/Jhc/Prim.hs lib/jhc/Jhc/IO.hs lib/jhc/Jhc/Int.hs lib/jhc/Jhc/Inst/Enum.hs \+    lib/jhc/Prelude/IO.hs lib/jhc/Jhc/Order.hs lib/jhc/System/C/Stdio.hs lib/jhc/Foreign/C/String.hs lib/jhc/Jhc/Show.hs \+    lib/jhc/Jhc/Handle.hs lib/jhc/Jhc/Addr.hs lib/jhc/Numeric.hs lib/jhc/Jhc/Float.hs lib/jhc/Jhc/Numeric.hs \+    lib/jhc/Jhc/Inst/Storable.hs lib/jhc/Jhc/Inst/Num.hs lib/jhc/Foreign/C/Types.hs lib/jhc/Data/Ratio.hs lib/jhc/Jhc/List.hs \+    lib/jhc/Jhc/Type/Float.hs lib/jhc/Jhc/Class/Num.hs lib/jhc/Foreign/Marshal/Utils.hs lib/jhc/Jhc/Basics.hs lib/jhc/System/Mem.hs \+    lib/jhc/Jhc/Type/Basic.hs lib/jhc/Jhc/ForeignPtr.hs lib/jhc/Jhc/Class/Real.hs lib/jhc/Jhc/Num.hs lib/jhc/Jhc/Text/Read.hs \+    lib/jhc/Jhc/Type/Ptr.hs lib/jhc/Foreign/C/Error.hs lib/jhc/Foreign/Storable.hs lib/jhc/Jhc/Type/Word.hs lib/jhc/Foreign/Ptr.hs \+    lib/jhc/Jhc/Inst/Order.hs lib/jhc/Jhc/Enum.hs lib/jhc/Jhc/Type/Handle.hs lib/jhc/Jhc/Tuples.hs lib/jhc/Jhc/String.hs \+    lib/jhc/Prelude/Float.hs lib/jhc/Jhc/Type/C.hs lib/jhc/Jhc/Class/Ord.hs lib/jhc/Jhc/Inst/PrimEnum.hs lib/jhc/Jhc/Inst/Show.hs \+    lib/jhc/Prelude/Text.hs lib/jhc/Foreign/Marshal/Alloc.hs lib/jhc/Foreign/Marshal/Array.hs lib/jhc/Jhc/Options.hs lib/jhc/Prelude/CType.hs \+    lib/jhc/Jhc/Monad.hs lib/jhc/System/IO/Unsafe.hs lib/jhc/System/Mem/StableName.hs lib/jhc/Jhc/Inst/Read.hs lib/jhc/Jhc/Maybe.hs \+    jhc-prim-1.0.hl+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+haskell-extras-0.8.1.hl: lib/haskell-extras/haskell-extras.yaml.m4 lib/haskell-extras/System/Info.hs lib/haskell-extras/Data/Int.hs lib/haskell-extras/Debug/Trace.hs lib/haskell-extras/Data/Array.hs \+    lib/haskell-extras/Data/Typeable.hs lib/haskell-extras/Text/Printf.hs lib/haskell-extras/System/Directory.hs lib/haskell-extras/Data/Word.hs lib/haskell-extras/Data/Maybe.hs \+    lib/haskell-extras/System/IO/Error.hs lib/haskell-extras/System/IO/Binary.hs lib/haskell-extras/System/CPUTime.hs lib/haskell-extras/System/IO/Pipe.hs lib/haskell-extras/Control/Monad/Instances.hs \+    lib/haskell-extras/Foreign/Marshal/Error.hs lib/haskell-extras/System/Exit.hs lib/haskell-extras/System/Environment.hs lib/haskell-extras/Data/Array/IO.hs lib/haskell-extras/Data/Char.hs \+    lib/haskell-extras/Data/Version.hs lib/haskell-extras/Text/Show/Functions.hs lib/haskell-extras/Control/Monad.hs lib/haskell-extras/Data/Functor.hs lib/haskell-extras/Data/Monoid.hs \+    lib/haskell-extras/System/Locale.hs lib/haskell-extras/System/IO.hs lib/haskell-extras/Foreign/Marshal/Pool.hs lib/haskell-extras/Prelude.hs lib/haskell-extras/Control/Monad/Fix.hs \+    lib/haskell-extras/Data/Complex.hs lib/haskell-extras/Data/IORef.hs lib/haskell-extras/System/Console/GetOpt.hs lib/haskell-extras/Data/List.hs lib/haskell-extras/System/Cmd.hs \+    lib/haskell-extras/System/Random.hs lib/haskell-extras/Data/Unicode.hs lib/haskell-extras/Foreign/ForeignPtr.hs lib/haskell-extras/System/Time.hs lib/haskell-extras/Control/Exception.hs \+    lib/haskell-extras/Foreign/StablePtr.hs lib/haskell-extras/Foreign/C.hs lib/haskell-extras/Data/Bits.hs lib/haskell-extras/Foreign/Marshal.hs lib/haskell-extras/Foreign.hs \+    lib/haskell-extras/Data/Array/Unboxed.hs lib/haskell-extras/Data/Function.hs lib/haskell-extras/Data/Ix.hs jhc-prim-1.0.hl jhc-1.0.hl+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+haskell2010-0.8.1.hl: lib/haskell2010/haskell2010.yaml.m4 haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+flat-foreign-1.0.hl: lib/flat-foreign/flat-foreign.yaml lib/flat-foreign/StablePtr.hs lib/flat-foreign/MarshalAlloc.hs lib/flat-foreign/CForeign.hs lib/flat-foreign/Storable.hs \+    lib/flat-foreign/Ptr.hs lib/flat-foreign/MarshalArray.hs lib/flat-foreign/Int.hs lib/flat-foreign/CString.hs lib/flat-foreign/Word.hs \+    lib/flat-foreign/CError.hs lib/flat-foreign/CTypes.hs lib/flat-foreign/MarshalError.hs lib/flat-foreign/MarshalUtils.hs lib/flat-foreign/Bits.hs \+    lib/flat-foreign/ForeignPtr.hs haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+haskell98-1.0.hl: lib/haskell98/haskell98.yaml lib/haskell98/System.hs lib/haskell98/List.hs lib/haskell98/Time.hs lib/haskell98/Array.hs \+    lib/haskell98/Random.hs lib/haskell98/Complex.hs lib/haskell98/Locale.hs lib/haskell98/CPUTime.hs lib/haskell98/Ratio.hs \+    lib/haskell98/Monad.hs lib/haskell98/Directory.hs lib/haskell98/IO.hs lib/haskell98/Ix.hs lib/haskell98/Char.hs \+    lib/haskell98/Maybe.hs haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+applicative-1.0.hl: lib/applicative/applicative.yaml lib/applicative/Control/Arrow.hs lib/applicative/Control/Applicative.hs lib/applicative/Data/Foldable.hs lib/applicative/Control/Category.hs \+    lib/applicative/Data/Traversable.hs haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(JHCPROG) $(LIB_OPTIONS) --build-hl $< -o $@+JHC_LIBS = jhc-prim-1.0.hl jhc-1.0.hl haskell-extras-0.8.1.hl haskell2010-0.8.1.hl flat-foreign-1.0.hl \+    haskell98-1.0.hl applicative-1.0.hl+containers-0.3.0.0.hl: lib/ext/containers.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl applicative-1.0.hl \+    lib/ext/containers.patch+	$(BUILD_EXTLIBS) $<+Diff-0.2.0.hl: lib/ext/Diff.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+html-1.0.1.2.hl: lib/ext/html.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+HUnit-1.2.5.1.hl: lib/ext/HUnit.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl deepseq-1.2.0.1.hl+	$(BUILD_EXTLIBS) $<+parsec-2.1.0.1.hl: lib/ext/parsec.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+pretty-1.0.1.2.hl: lib/ext/pretty.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+QuickCheck-1.2.0.1.hl: lib/ext/QuickCheck.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+safe-0.3.3.hl: lib/ext/safe.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+smallcheck-0.6.1.hl: lib/ext/smallcheck.cabal haskell-extras-0.8.1.hl haskell98-1.0.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+xhtml-3000.2.1.hl: lib/ext/xhtml.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+transformers-0.2.1.0.hl: lib/ext/transformers.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl applicative-1.0.hl+	$(BUILD_EXTLIBS) $<+filepath-1.3.0.1.hl: lib/ext/filepath.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl+	$(BUILD_EXTLIBS) $<+deepseq-1.2.0.1.hl: lib/ext/deepseq.cabal haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl containers-0.3.0.0.hl \+    applicative-1.0.hl+	$(BUILD_EXTLIBS) $<+bytestring-0.9.2.0.hl: lib/ext/bytestring.yaml haskell-extras-0.8.1.hl jhc-prim-1.0.hl jhc-1.0.hl lib/ext/bytestring.patch+	$(BUILD_EXTLIBS) $<+JHC_EXT_LIBS = containers-0.3.0.0.hl Diff-0.2.0.hl html-1.0.1.2.hl HUnit-1.2.5.1.hl parsec-2.1.0.1.hl \+    pretty-1.0.1.2.hl QuickCheck-1.2.0.1.hl safe-0.3.3.hl smallcheck-0.6.1.hl xhtml-3000.2.1.hl \+    transformers-0.2.1.0.hl filepath-1.3.0.1.hl deepseq-1.2.0.1.hl
+ rts/HsFFI.h view
@@ -0,0 +1,42 @@+/* HsFFI.h for jhc */++#ifndef _JHC_HSFFI_H+#define _JHC_HSFFI_H++#include <stdint.h>+#include <stdbool.h>+#include <stddef.h>++typedef int32_t HsInt;+typedef int8_t  HsInt8;+typedef int16_t HsInt16;+typedef int32_t HsInt32;+typedef int64_t HsInt64;++typedef uint32_t HsWord;+typedef uint8_t  HsWord8;+typedef uint16_t HsWord16;+typedef uint32_t HsWord32;+typedef uint64_t HsWord64;++typedef wchar_t HsChar;+typedef bool HsBool;++typedef double HsDouble;+typedef float HsFloat;++typedef void *HsPtr;+typedef void (*HsFunPtr)(void);+typedef void *HsStablePtr;++#define HS_BOOL_FALSE 0+#define HS_BOOL_TRUE 1++void hs_init (int *argc, char **argv[]);+void hs_exit (void);+void hs_set_argv(int argc, char *argv[]);+void hs_perform_gc(void);+void hs_free_stable_ptr(HsStablePtr sp);+void hs_free_fun_ptr(HsFunPtr fp);++#endif
+ src/C/Generate.hs view
@@ -0,0 +1,692 @@+module C.Generate(+    Annotate(..),+    Structure(..),+    (=*),+    (&),+    (*#),+    (+#),+    ToExpression(..),+    ToStatement(..),+    eq,+    basicStructure,+    anonStructType,+    basicType,+    basicGCType,+    cast,+    noAssign,+    cif,+    constant,+    creturn,+    dereference,+    reference,+    Draw(err),+    drawG,+    emptyExpression,+    enum,+    Expression(),+    Constant(),+    expressionRaw,+    statementOOB,+    indexArray,+    function,+    Function(functionName),+    functionCall,+    indirectFunctionCall,+    FunctionOpts(..),+    generateC,+    goto,+    subBlock,+    isEmptyExpression,+    label,+    localVariable,+    name,+    Name(),+    newVar,+    newDeclVar,+    newAssignVar,+    newTmpVar,+    forLoop,+    nullPtr,+    number,+    floating,+    operator,+    project,+    project',+    projectAnon,+    ptrType,+    funPtrType,+    renderG,+    sizeof,+    Statement(),+    string,+    structAnon,+    structType,+    switch',+    character,+    toName,+    Type(),+    uoperator,+    variable,+    voidType,+    voidStarType+    ) where++import Data.Char+import Control.Monad+import Control.Monad.RWS(RWS,MonadState(..),MonadWriter(..),MonadReader(..),runRWS,asks,MonadFix(..))+import Control.Monad.Writer(censor, runWriter)+import Data.Monoid(Monoid(..))+import Data.List(intersperse)+import Data.Maybe(isNothing)+import Numeric+import Text.PrettyPrint.HughesPJ(Doc,render,nest,($$),($+$))+import qualified Data.Foldable as Seq+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Traversable as Seq++import Doc.DocLike+import Util.Gen+import Util.SetLike++data Env = Env {+    envUsedLabels :: Set.Set Name,+    envInScope    :: Set.Set Name+    }++--envInScope_u f e = e { envInScope = f $ envInScope e }++emptyEnv = Env { envUsedLabels = mempty, envInScope = mempty }++newtype G a = G (RWS Env [(Name,Type)] (Int,Map.Map [Type] Name) a)+    deriving(Monad,MonadWriter [(Name,Type)],MonadState (Int,Map.Map [Type] Name),MonadReader Env,MonadFix)++newtype Name = Name String+    deriving(Eq,Ord)++instance Show Name where+    show (Name n) = n++data TypeHint = TypeHint {+    thPtr :: !Bool,+    thConst :: !Bool,+    thNoAssign :: !Bool,+    thOmittable :: !Bool+    }++hintConst = typeHint { thConst = True, thOmittable = True }+hintPtr   = typeHint { thPtr = True }++typeHint = TypeHint { thPtr = False, thConst = False, thNoAssign = False, thOmittable = False }++data Expression = Exp TypeHint E++newtype Statement = St (Seq.Seq Stmt)++data Stmt =+    SD (G Doc)+    | SGoto Name+    | SLabel Name+    | SReturn Expression+    | SBlock Statement+    | SIf Expression Statement Statement+    | SSwitch Expression [(Maybe Constant,Statement)]++newtype Constant = C (G Doc)++sd x = stmt (SD x)+stmt s = St (Seq.singleton s)++stmtMapStmt :: Monad m => (Stmt -> m Stmt) -> Stmt -> m Stmt+stmtMapStmt f s = g s where+    g (SBlock sb) = return SBlock `ap` h sb+    g (SIf e s1 s2) = return (SIf e) `ap` h s1 `ap` h s2+    g (SSwitch e ss) = do+        ss <- forM ss $ \ (x,y) -> do+            y <- h y+            return (x,y)+        return $ SSwitch e ss+    g s = return s+    h (St sms) = return St `ap` Seq.mapM f sms++-- The Bool in TB and is whether the GC needs to consider the types to+-- possibly contain garbage collectable pointers.+data Type = TB String Bool | TPtr Type | TAnon [Type] | TNStruct Name | TFunPtr Type [Type]+    deriving(Eq,Ord)++data E = ED (G Doc) | EP E | EE++terr s = text "/* ERROR: " <> text s <> text " */"++class Draw d where+    draw :: d -> G Doc+    pdraw :: d -> G Doc+    pdraw = draw+    err :: String -> d+    err s = error s++instance Draw Statement where+    draw (St ss) = vcat (map draw $ Seq.toList ss)+    err s = sd $ terr s++instance Draw Stmt where+    err s = SD (terr s)++    draw (SD g) = g+    draw (SReturn e) | isEmptyExpression e = text "return;"+    draw (SReturn e) = text "return " <> draw e <> char ';'+    draw (SLabel n@(Name s)) = do+        ls <- asks envUsedLabels+        if n `member` ls then  text s <> char ':' <> char ';' else return mempty+    draw (SGoto (Name s)) = text "goto" <+> text s <> char ';'+    draw (SBlock s) = do+        s <- subBlockBody s+        return $ vcat [char '{', nest 4 s, char '}']+    draw (SIf exp thn els) = do+        exp <- draw exp+        thn <- subBlockBody thn+        els <- subBlockBody els+        return $ text "if" <+> parens exp <+> lbrace <$> nest 4 thn <$> rbrace <+> text "else" <+> lbrace <$> nest 4 els <$> rbrace+    draw (SSwitch e ts) = text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where+        sc (Just x,ss) = do ss <- draw (SBlock ss); x <- draw x; return $ text "case" <+> x <> char ':' $$ nest 4 (ss $$ text "break;")+        sc (Nothing,ss) = do ss <- draw (SBlock ss); return $ text "default:"  $$  ( nest 4 ss $$ text "break;")+        md = if any isNothing (fsts ts) then empty else text "default: jhc_case_fell_off(__LINE__);"++--subBlockBody s = draw s+subBlockBody s = do+    let vcmp (n,t@(TB _ b)) = (not b,n)+        vcmp (n,t) = (True,n)+    is <- asks envInScope+    (body,uv) <-  censor (const []) $ listen (draw s)+    uv' <- forM [ (x,t) | (x,t) <- snubUnder vcmp uv, (x /= toName "v0") && (x `Set.notMember` is)] $ \ (n,t) -> do+        t <- draw t+        return $ t <+> tshow n <> semi+    return $ vcat uv' $$ body++instance Draw E where+    draw (ED g) = g+    draw (EP e) = draw e+    draw EE = empty+    pdraw (ED g) = g+    pdraw (EP e) = parens (draw e)+    pdraw EE = empty+    err s = ED $ terr s++instance Draw Expression where+    draw (Exp _ e) = draw e+    pdraw (Exp _ e) = pdraw e+    err s = (Exp typeHint (err s))++instance Draw Name where+    draw (Name s) = text s+    err s = Name $ terr s++instance Draw Constant where+    draw (C x) = x+    err s = C $ terr s++instance Draw Type where+    draw (TB x _) = text x+    draw (TPtr x) = draw x <> char '*'+    draw (TAnon ts) = do+        (n,mp) <- get+        case Map.lookup ts mp of+            Just x -> text "struct" <+> draw x+            Nothing -> do+                let nm = name ("tup" ++ show n)+                put (n + 1,Map.insert ts nm mp)+                text "struct" <+> draw nm+    draw (TNStruct n) = text "struct" <+> draw n+    draw (TFunPtr r as) = draw r <+> text "(*)" <> tupled (map draw as)++    err s = TB (terr s) False++-- expressions+sizeof :: Type -> Expression+sizeof t = expC (text "sizeof" <> parens $ draw t)++cast :: Type -> Expression -> Expression+cast t e = expDC (parens (draw t) <> pdraw e)++functionCall' fe es = expD (draw fe <> tupled (map draw es))++functionCall :: Name -> [Expression] -> Expression+functionCall = functionCall'++indirectFunctionCall :: Expression -> [Expression] -> Expression+indirectFunctionCall e = functionCall' (expD (parens (draw e)))++dereference :: Expression -> Expression+dereference x = expDC $ char '*' <> pdraw x++noAssign :: Expression -> Expression+noAssign (Exp th v) = Exp th { thNoAssign = True } v++reference :: Expression -> Expression+reference x = expDC $ char '&' <> pdraw x++indexArray :: Expression -> Expression -> Expression+indexArray w i = expDO (pdraw w <> char '[' <> pdraw i <> char ']')++project :: Name -> Expression -> Expression+project n e = expDO (pdraw e <> char '.' <> draw n)++project' :: Name -> Expression -> Expression+project' n e = expDO (pdraw e <> text "->" <> draw n)++projectAnon :: Int -> Expression -> Expression+projectAnon n e = project (Name $ 't':show n) e++variable :: Name -> Expression+variable n = expDO (draw n)++localVariable :: Type -> Name -> Expression+localVariable t n = expD $ do+    tell [(n,t)]+    draw n++statementOOB :: Statement -> Statement+statementOOB s = (sd $ draw s >> return empty)++instance Monoid Statement where+    mempty = St mempty+    mappend (St as) (St bs) = St $ pairOpt stmtPairOpt as bs++stmtPairOpt a b = f a b where+    f (SGoto l) y@(SLabel l')+        | l == l' = Just y+        | otherwise = Nothing+    f SReturn {} SLabel {} = Nothing+    f x@SGoto {} _  = Just x+    f x@SReturn {} _  = Just x+    f _ _ = Nothing++-- combine two sequences, attempting pairwise peephole optimizations++pairOpt :: (s -> s -> Maybe s) -> Seq.Seq s -> Seq.Seq s -> Seq.Seq s+pairOpt peep as bs = f as bs where+    f as bs | as' Seq.:> a <- Seq.viewr as, b Seq.:< bs' <- Seq.viewl bs = case peep a b of+        Just ab -> as' `f` Seq.singleton ab `f` bs'+        Nothing -> as Seq.>< bs+    f as bs =  as Seq.>< bs++emptyExpression = Exp typeHint EE++expressionRaw s = expD $ text s++isEmptyExpression (Exp _ EE) = True+isEmptyExpression _ = False+{-+structUnnamed :: Type -> [Expression] -> Expression+globalVar :: Name -> Type -> Expression+-}++commaExpression :: [Expression] -> Expression+commaExpression [] = emptyExpression+commaExpression [e] = e+commaExpression ss = expD $ do+    ds <- mapM draw ss+    return (tupled ds)++structAnon :: [(Expression,Type)] -> Expression+--structAnon _ = err "structAnon"+structAnon es = Exp typeHint $ ED $ do+    (n,mp) <- get+    put (n + 1,mp)+    let nm = name ("_t" ++ show n)+        lv = localVariable (anonStructType (snds es)) nm+    draw $ commaExpression $ [operator "=" (projectAnon i lv) e | e <- fsts es | i <- [0..] ] ++ [lv]++operator :: (ToExpression a,ToExpression b) => String -> a -> b -> Expression+operator o x y = expDC (pdraw (toExpression x) <+> text o <+> pdraw (toExpression y))++uoperator :: String -> Expression -> Expression+uoperator o x = expDC (text o <> pdraw x)++constant :: Constant -> Expression+constant c = expD (draw c)++string :: String -> Expression+string s = Exp hintPtr (ED (return $ text (show s))) -- TODO, use C quoting conventions++nullPtr = Exp hintPtr (ED $ text "NULL")++name = Name++expDO x = Exp typeHint { thOmittable = True } (ED x)+expD x = Exp typeHint (ED x)+expDC x = Exp hintConst (EP $ ED x)+expC x = Exp hintConst (ED x)++-- Constant+enum :: Name -> Constant+enum n = C (draw n)++number :: Integer -> Constant+number i = C (tshow i)++floating :: Double -> Constant+floating i = C (tshow i)++character :: Char -> Constant+character c = C (tshow c)++cTrue = C (text "true")+cFalse = C (text "false")++-- statements+expr :: Expression -> Statement+expr e | isEmptyExpression e = mempty+expr e = sd $ draw e <> char ';'++creturn :: Expression -> Statement+creturn e = stmt $ SReturn e++assign :: Expression -> Expression -> Statement+assign (Exp TypeHint { thNoAssign = True} _) (Exp TypeHint { thOmittable = True } _)  = mempty+assign (Exp TypeHint { thNoAssign = True} _) b = expr b+assign a b = expr $ operator "=" a b++label :: Name -> Statement+label n = stmt $ SLabel n++goto :: Name -> Statement+goto n = stmt $ SGoto n++massign a b = if isEmptyExpression b then toStatement a else assign a b++newTmpVar t e = do+    u <- newUniq+    let n = name $ 'x':show u+        d = sd $ do+            va <- draw (variable n `massign` e)+            t <- draw t+            return $ t <+> va+    return (d,variable n)++newAssignVar t n e = do+    let d = sd $ do+            va <- draw (variable n `massign` e)+            t <- draw t+            return $ t <+> va+    return d++newVar t = do+    u <- newUniq+    let n = name $ 'x':show u+    return (localVariable t n)++newDeclVar t = do+    u <- newUniq+    let n = name $ 'x':show u+    return (sd (tell [(n,t)] >> return mempty),variable n)++labelPull :: Statement -> (Statement,Statement)+labelPull (St ss) = f ss mempty where+    f ss rr | ss' Seq.:> l@SLabel {} <- Seq.viewr ss = f ss' (Seq.singleton l `mappend` rr)+            | otherwise = (St ss,St rr)++switch' :: Expression -> [(Maybe Constant,Statement)]  -> Statement+switch' e es = (stmt $ SSwitch e es') `mappend` ls where+     (es',ls) = runWriter $ mapM f es+     f (c,s) = tell l >> return (c,s') where (s',l) = labelPull s++cif :: Expression -> Statement -> Statement -> Statement+cif exp thn els = (stmt $ SIf exp thn' els') `mappend` la `mappend` lb where+    (thn',la) = labelPull thn+    (els',lb) = labelPull els++subBlock st = stmt (SBlock st') `mappend` la  where+    (st',la) = labelPull st++forLoop :: Expression -> Expression -> Expression -> Statement -> Statement+forLoop i from to body = sd $ do+    i <- draw i+    from <- draw from+    to <- draw to+    body <- draw body+    return $ text "for" <> parens (i <+> equals <+> from <> semi <+> i <+> text "<" <+> to <> semi <+> i <> text "++" ) <+> lbrace <$> nest 4 body <$> rbrace++data Function = F {+    functionName :: Name,+    functionReturnType :: Type,+    functionArgs :: [(Name,Type)],+    functionOptions :: [FunctionOpts],+    functionBody :: Statement+    }++data FunctionOpts = Public | Attribute String+    deriving(Eq)++function :: Name -> Type -> [(Name,Type)] -> [FunctionOpts] -> Statement -> Function+function n t as o s = F n t as o s++drawFunction :: Function -> G (Doc,Doc)+drawFunction f = do+    frt <- draw (functionReturnType f)+    cenv <- ask+    let env = cenv { envUsedLabels = ul, envInScope = Set.fromList $ fsts (functionArgs f) } where+        ul = Set.fromList $ Seq.toList $ Seq.foldMap (travCollect stmtMapStmt g) stseq+        St stseq = functionBody f+        g (SGoto n) = Seq.singleton n+        g s = mempty+        vcmp (n,t@(TB _ b)) = (not b,n)+        vcmp (n,t) = (True,n)+    (body,uv) <- local (const env) $ listen (draw (functionBody f))+    uv' <- forM [ (x,t) | (x,t) <- snubUnder vcmp uv, x `notElem` fsts (functionArgs f)] $ \ (n,t) -> do+        t <- draw t+        return $ t <+> tshow n <> semi+    name <- draw (functionName f)+    fas <- forM (functionArgs f) $ \ (n,t) -> do+        n <- draw n+        t <- draw t+        return $ t <+> n+    let fas' = if null fas then [text "void"] else fas+        proto = static <+> frt <+> name <> tupled fas' <> parms <> semi+        proto' = static <+> frt <> parms $$ name <> tupled fas'+        static = if Public `elem` functionOptions f then empty else text "static"+        parms = char ' ' <> hsep [ text s | Attribute s <- functionOptions f]+    return (proto, proto' $+$ lbrace $+$ nest 8 (vcat uv' $$ body) $+$ rbrace)++-- types+anonStructType :: [Type] -> Type+anonStructType ts = TAnon ts++basicType :: String -> Type+basicType s = TB s False++-- | a basic type the garbage collector might want to follow, guarenteed to be+-- the size of a pointer.+basicGCType :: String -> Type+basicGCType s = TB s True++structType :: Name -> Type+structType n = TNStruct n++ptrType :: Type -> Type+ptrType t = TPtr t++funPtrType :: Type -> [Type] -> Type+funPtrType r as = TFunPtr r as++-- type constants+voidStarType :: Type+voidStarType = ptrType voidType++voidType :: Type+voidType = basicType "void"++class Annotate e where+    annotate :: String -> e -> e++instance Annotate Statement where+    --annotate c s@(SD si _) = SD si ((text "/* " <> text c <> text " */") <$> draw s)+    annotate c s = sd (text "/* " <> text c <> text " */") `mappend` s++mangleIdent xs = f xs where+    f (x:xs) | isAlphaNum x = x:f xs+    f ('.':'.':xs) = '$':g ('.':'.':xs)+    f ('.':xs) = '_':f xs+    f ('_':xs) = "__" ++ f xs+    f ('@':xs) = "$_" ++ f xs  -- this is safe because we wouldn't switch to g-mode just for a underscore.+    f xs@(_:_) = '$':g xs+    f [] = []+    g (x:xs) | isDigit x = x:g xs+    g (x:xs) | isAlpha x = '$':f xs+    g ('.':xs) = "_" ++ g xs+    g ('@':xs) = "a" ++ g xs+    g (',':xs) = "c" ++ g xs+    g ('^':xs) = "C" ++ g xs+    g ('(':xs) = "L" ++ g xs+    g (')':xs) = "R" ++ g xs+    g ('[':xs) = "B" ++ g xs+    g (']':xs) = "E" ++ g xs+    g ('$':xs) = "d" ++ g xs+    g ('%':xs) = "P" ++ g xs+    g ('#':xs) = "h" ++ g xs+    g ('/':xs) = "s" ++ g xs+    g ('=':xs) = "e" ++ g xs+    g ('+':xs) = "p" ++ g xs+    g ('-':xs) = "m" ++ g xs+    g ('!':xs) = "b" ++ g xs+    g ('>':xs) = "r" ++ g xs+    g ('<':xs) = "l" ++ g xs+    g ('\'':xs) = "t" ++ g xs+    g ('_':xs) = "u" ++ g xs+    g (x:xs) = 'x':showHex (ord x) (g xs)+    g [] = []++toName s = Name (mangleIdent s)++data Structure = Structure {+    structureName :: Name,+    structureFields :: [(Name,Type)],+    structureNeedsDiscriminator :: Bool,    -- ^ emit a macro that declares a discriminator when needed+    structureHasDiscriminator   :: Bool,    -- ^ the first field must appear first in the on memory layout, don't move it.+    structureAligned :: Bool                -- ^ this structure needs to be aligned to a pointer boundry, even if it woudn't be otherwise.+    }++basicStructure = Structure {+    structureName = error "basicStructure: Name",+    structureFields = [],+    structureNeedsDiscriminator = False,+    structureHasDiscriminator   = False,+    structureAligned            = False+    }++generateC+    :: [Function]              -- ^ functions+    -> [Structure]             -- ^ extra structures+    -> (Doc,Doc)               -- ^ final result+generateC fs ss = ans where+    G ga = do+        fs <- mapM drawFunction fs+        let (protos,bodys) = unzip fs+        let shead = vcat [ text "struct" <+> tshow (structureName s) <> (if structureAligned s then text " A_ALIGNED" else empty) <> text ";" | s <- ss ]+        shead2 <- declStructs ss+        return (shead $$ line $$ shead2 $$ vcat protos, line $$  vsep bodys)+    ((hd,fns),(_,ass),_written) = runRWS ga emptyEnv (1,Map.empty)++    anons = [ basicStructure { structureName = n, structureFields = fields ts }  | (ts,n) <- Map.toList ass ] where+        fields :: [Type] -> [(Name,Type)]+        fields ts = [ (name ('t':show tn),t) | t <- ts | tn <- [0::Int .. ]]+    G anons' = declStructs anons+    (anons'',_,_) = runRWS anons' emptyEnv (1,Map.empty)+    ans = (hd $$ anons'',fns)++    declStructs ss = liftM vsep $ forM ss $ \ s@Structure { structureName = n, structureFields = ts } -> do+        let tsort [] = []+            tsort (t:ts) | structureHasDiscriminator s = t:rsort ts+                         | otherwise = rsort (t:ts)+            rsort = sortUnder (cmp . snd)+            numGC = length [ () | (_,TB _ True) <- ts ]+            ppri = if numGC /= 0 then 2 else 5+            -- pointers first, garbage collected, then rest+            cmp (TB _ True) = (1::Int)+            cmp TFunPtr {}  = ppri+            cmp TPtr {}     = ppri+            cmp (TB s _)    = maybe 5  id (lookup s tmap)+            cmp _ = 5+            tmap = [ "uintmax_t" ==> 3, "uintptr_t" ==> ppri, "double" ==> 4, "uint32_t" ==> 6, "float" ==> 6, "uint16_t" ==> 7, "uint8_t" ==> 8]+            x ==> y = (x,y)++        ts' <- forM (tsort ts) $ \ (n,t) -> do+            t <- draw t+            return $ t <+> tshow n <> semi+        return $ text "struct" <+> tshow n <+> lbrace $$ nest 4 (vcat $ (if structureNeedsDiscriminator s  then text "what_t what;" else empty):ts') $$ rbrace <> semi++line = text ""+vsep xs = vcat $ intersperse line xs++instance Show Expression where+    show e = renderG e++renderG x = render $ drawG x++drawG :: Draw d => d -> Doc+drawG x = fns where+    G ga = draw x+    (fns,_,_) = runRWS ga emptyEnv (1,Map.empty)++------------+-- C helpers+------------++infix 3 `eq`++eq :: (ToExpression x, ToExpression y) => x -> y -> Expression+eq = operator "=="++infix 2 =*++(=*) :: (ToExpression x, ToExpression y) => x -> y -> Statement+x =* y = toExpression x `assign` toExpression y++class ToStatement a  where+    toStatement :: a -> Statement++instance ToStatement Statement where+    toStatement x = x++instance ToStatement Expression where+    toStatement x = expr x++class ToExpression a where+    toExpression :: a -> Expression++instance ToExpression Expression where+    toExpression e = e++instance ToExpression a => ToStatement a where+    toStatement x = toStatement $ toExpression x++instance ToExpression Constant where+    toExpression c = constant c++instance ToExpression Name where+    toExpression c = variable c++instance ToExpression Char where+    toExpression c = constant $ character c++instance ToExpression Int where+    toExpression c = constant $ number $ fromIntegral c++instance ToExpression Integer where+    toExpression c = constant $ number c++instance ToExpression Bool where+    toExpression b = toExpression $ if b then cTrue else cFalse++instance (ToExpression a,ToExpression b) => ToExpression (a,b) where+    toExpression (x,y) = commaExpression [toExpression x,toExpression y]++infixl 1 &+++(&) :: (ToStatement a,ToStatement b) => a -> b -> Statement+x & y = toStatement x `mappend` toStatement y++x *# y = operator "*" (toExpression x) (toExpression y)+x +# y = operator "+" (toExpression x) (toExpression y)
+ src/Cmm/Number.hs view
@@ -0,0 +1,24 @@+module Cmm.Number(Number(..),toIntegral) where++import Data.Binary+import Data.Ratio++newtype Number = Number Rational+    deriving(Num,Eq,Ord,Binary,Real,Fractional,RealFrac,Enum)++instance Integral Number where+    toInteger (Number x) = case denominator x of+        1 -> numerator x+        _ -> error $ "toInteger: Number not integer " ++ show x+    quotRem x y = case toInteger x `quotRem` toInteger y  of+        (x,y) -> (fromInteger x,fromInteger y)++instance Show Number where+    showsPrec n (Number r) = case denominator r of+        1 -> showsPrec n (numerator r)+        _ -> showsPrec n (realToFrac r :: Double)++toIntegral :: (Integral i,Monad m) => Number -> m i+toIntegral (Number r) = case denominator r of+    1 -> return $ fromInteger (numerator r)+    _ -> fail $ "toInteger: Number not integer " ++ show r
+ src/Cmm/OpEval.hs view
@@ -0,0 +1,202 @@+module Cmm.OpEval(+    Expression(..),+    convOp,+    convNumber,+    convCombine,+    binOp,+    binOp',+    unOp+    ) where++import Data.Maybe+import qualified Data.Map as Map++import Cmm.Number+import Cmm.Op++class Expression t e | e -> t where+    toConstant :: e -> Maybe (Number,t)+    toExpression :: Number -> t -> e+    toBool :: Bool -> e+    createBinOp :: BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> e+    createUnOp  :: UnOp -> Ty -> Ty -> e -> t -> e+    fromUnOp :: e -> Maybe (UnOp,Ty,Ty,e,t)+    fromBinOp :: e -> Maybe (BinOp,Ty,Ty,Ty,e,e,t)+    caseEquals :: e -> (Number,t) -> e -> e -> e++    equalsExpression :: e -> e -> Bool++    toConstant _ = Nothing+    fromBinOp _ = Nothing+    fromUnOp _ = Nothing+    equalsExpression _ _ = False++TyBool `tyLte` _ = True+TyBits (Bits x) _ `tyLte` TyBits (Bits y) _ = x <= y+_ `tyLte` TyBits (BitsArch BitsMax) _ = True+TyBits (Bits x) _ `tyLte` TyBits (BitsArch BitsPtr) _ = x <= 32+x `tyLte` y  = x == y+x `tyEq` y = (x `tyLte` y) && (y `tyLte` x)++{-+x `tyLt` y = (x `tyLte` y) && not (y `tyLte` x)+x `tyGt` y = y `tyLt` x+x `tyGte` y = y `tyLte` x+-}++convOp :: ConvOp -> Ty -> Ty -> Maybe ConvOp+convOp F2I _ _ = Just F2I+convOp I2F _ _ = Just I2F+convOp F2U _ _ = Just F2U+convOp U2F _ _ = Just U2F+convOp _ t1 t2 | t1 == t2 = Nothing+convOp U2U t1 t2 | t2 `tyLte` t1 = Just Lobits+convOp I2I t1 t2 | t2 `tyLte` t1 = Just Lobits+convOp U2U t1 t2 | t1 `tyLte` t2 = Just Zx+convOp I2I t1 t2 | t1 `tyLte` t2 = Just Sx+convOp n _ _ = Just n++convNumber :: ConvOp -> Ty -> Ty -> Number -> Number+convNumber _ _ _ n = n+{-+convNumber :: ConvOp -> Val -> Ty -> Val+convNumber F2I (Val _ (ValFloat f)) ty = Val ty (fromInteger $ truncate f)+convNumber F2U (Val _ (ValFloat f)) ty = Val ty (if f < 0 then 0 else fromInteger $ truncate f)+convNumber I2F (Val _ (ValInteger f)) ty = Val ty (ValFloat $ fromInteger f)+convNumber U2F (Val _ (ValInteger f)) ty = Val ty (ValFloat $ fromInteger f)+convNumber _ (Val _ v) ty  = (Val ty v)+-}++convCombine :: Ty -> ConvOp -> Ty -> ConvOp -> Ty -> Maybe ConvOp+convCombine _ c1 _ c2 _ | c1 `elem` [F2I,I2F,U2F,F2U] || c2 `elem` [F2I,I2F,U2F,F2U] = Nothing+convCombine _ c1 t2 c2 t3 | tyEq t2 t3 && c1 == c2 = Just c2+convCombine _ _ _ _ _ = Nothing++binOp :: Expression t e => BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> Maybe e+-- evaluate expressions at compile time if we can+binOp bop t1 t2 tr e1 e2 str | Just (v1,t1) <- toConstant e1, Just (v2,t2) <- toConstant e2 = f bop v1 v2 where+    f Add v1 v2 = return $ toExpression (v1 + v2) str+    f Sub v1 v2 = return $ toExpression (v1 - v2) str+    f Mul v1 v2 = return $ toExpression (v1 * v2) str+    f op v1 v2 | v2 /= 0, isJust ans = ans where+        ans = case op of+            Div  -> return $ toExpression (v1 `div` v2) str+            Mod  -> return $ toExpression (v1 `mod` v2) str+            Quot -> return $ toExpression (v1 `quot` v2) str+            Rem  -> return $ toExpression (v1 `rem` v2) str+            UDiv -> return $ toExpression (v1 `div` v2) str+            UMod -> return $ toExpression (v1 `mod` v2) str+            FDiv -> return $ toExpression (v1 / v2) str+            _ -> Nothing+    f FMul v1 v2 = return $ toExpression (v1 * v2) str+    f FAdd v1 v2 = return $ toExpression (v1 + v2) str+    f FSub v1 v2 = return $ toExpression (v1 - v2) str+    f FPwr v1 v2 = return $ toExpression (realToFrac (realToFrac v1 ** realToFrac v2 :: Double)) str++    f op v1 v2 | Just v <- Map.lookup op ops = return $ toBool (v1 `v` v2) where+        ops = Map.fromList [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)),+               (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=)), (Eq,(==)),(NEq,(/=))]++    f op v1 v2 | Just v <- Map.lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where+        ops = Map.fromList [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))]+    f _ _ _ =  Nothing+-- we normalize ops such that constants are always on the left side+binOp bop t1 t2 tr e1 e2 str | Just _ <- toConstant e2, Just bop' <- commuteBinOp bop = Just $ createBinOp bop' t2 t1 tr e2 e1 str+binOp bop t1 t2 tr e1 e2 str = f bop e1 e2 where+    zero = toExpression 0 str+    one = toExpression 1 str+    true = toBool True+    false = toBool False++    f op e1 e2 | Just (v,_) <- toConstant e2 = ans v where+        ans 0 = case op of+            Shr  -> return e1+            Shra -> return e1+            Shl  -> return e1+            Rotl -> return e1+            Rotr -> return e1+            Sub  -> return e1+            FSub -> return e1+            FPwr -> return one+            _ -> Nothing+        ans 1 = case op of+            Div -> return e1+            Mod -> return zero+            UDiv -> return e1+            UMod -> return zero+            Quot -> return e1+            Rem  -> return zero+            FPwr -> return e1+            FDiv -> return e1+            Mul  -> return e1+            FMul  -> return e1+            _ -> Nothing+        ans _ = Nothing++    f op e1 e2 | Just (v,t1) <- toConstant e1 = eans t1 v where+        eans t1 v1 = case op of+            Eq  -> return $ caseEquals e2 (v1,t1) true false+            NEq -> return $ caseEquals e2 (v1,t1) false true+            _ -> ans t1 v1+        ans t1 0 = case op of+            Shr  -> return zero+            Shra -> return zero+            Shl  -> return zero+            Rotl -> return zero+            Rotr -> return zero+            And  -> return zero+            Or   -> return e2+            Xor  -> return e2+            Add  -> return e2+            Mul  -> return zero+            UGt  -> return false+            ULte -> return true+            FAdd -> return e2+            UGte -> return $ caseEquals e2 (0,t1) true false+            ULt  -> return $ caseEquals e2 (0,t1) false true+            _ -> Nothing+        ans t1 1 = case op of+            Mul  -> return e2+            FMul -> return e2+            UGt  -> return $ caseEquals e2 (0,t1) true false+            _ -> Nothing+        ans _ _ = Nothing++    f op e1 e2 | e1 `equalsExpression` e2, isJust ans = ans where+        ans = case op of+            Eq    -> return true+            NEq   -> return false+            Lte   -> return true+            Gte   -> return true+            Lt    -> return false+            Gt    -> return false+            ULte  -> return true+            UGte  -> return true+            ULt   -> return false+            UGt   -> return false+            Sub   -> return zero+            Xor   -> return zero+            And   -> return e1+            Or    -> return e1+            _ -> Nothing++    f bop e1 e2 | isAssociative bop, Just (bop',t1',t2',tr',e1',e2',str') <- fromBinOp e1, bop == bop' = Just $+        createBinOp bop tr tr tr e1' (createBinOp bop tr tr tr e2' e2 str) str+    f bop e1 e2 = Nothing -- return $ createBinOp bop t1 t2 tr e1 e2 str++binOp' :: Expression t e => BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> e+binOp' bop t1 t2 tr e1 e2 str =  case binOp bop t1 t2 tr e1 e2 str of+    Just e -> e+    Nothing -> createBinOp bop t1 t2 tr e1 e2 str++unOp :: Expression t e => UnOp -> Ty -> Ty -> e -> t -> Maybe e+unOp op t1 tr e str | Just (v,t) <- toConstant e = f op v where+    f Neg v = return $ toExpression (negate v) str+    f FNeg v = return $ toExpression (negate v) str+    f FAbs v = return $ toExpression (abs v) str+    f Sin v = return $ toExpression (realToFrac $ sin (realToFrac v :: Double)) str+    f Cos v = return $ toExpression (realToFrac $ cos (realToFrac v :: Double)) str+    f Tan v = return $ toExpression (realToFrac $ tan (realToFrac v :: Double)) str+    f Sqrt v = return $ toExpression (realToFrac $ sqrt (realToFrac v :: Double)) str+    f _ _ = Nothing+unOp op t1 tr e str = Nothing
+ src/DerivingDrift/DataP.hs view
@@ -0,0 +1,26 @@+module DerivingDrift.DataP where++import Name.Name(Name)+import FrontEnd.HsSyn++data Statement = DataStmt | NewTypeStmt+    deriving (Eq,Show)++data Data = D {+    name :: Name,		-- type name+    constraints :: [(Class,Var)],+    vars :: [Var],		-- Parameters+    body :: [Body],+    derives :: [Class],		-- derived classes+    statement :: Statement+    } deriving (Eq,Show)++data Body = Body {+    constructor :: Constructor,+    labels :: [Name],+    types :: [HsBangType]+    } deriving (Eq,Show)++type Var = String+type Class = String+type Constructor = String
+ src/DerivingDrift/Drift.hs view
@@ -0,0 +1,60 @@+module DerivingDrift.Drift(driftDerive,driftResolvedNames) where++import Data.Char+import qualified Data.Map as Map++import DerivingDrift.DataP+import DerivingDrift.StandardRules+import FrontEnd.Class+import FrontEnd.HsParser+import FrontEnd.HsSyn+import FrontEnd.ParseMonad+import Name.Name+import Text.PrettyPrint.HughesPJ(render)++driftDerive :: HsModule -> [HsDecl]+driftDerive hsModule = if null ss then [] else hsModuleDecls hsMod+  where+    --hsMod = case parse (unlines ss) (SrcLoc (show $ hsModuleName hsModule) 1 1) 0 [] of+    hsMod = case snd $ runParser parse ss  of+        ParseOk e -> e+        ParseFailed sl err -> error $ "internal parse error(driftDerive): " ++ show sl ++ err  ++ "\n" ++ ss+    ss = unlines [ n | Just n <- map driftDerive' $ hsModuleDecls hsModule, any (not . isSpace) n ]++driftDerive' :: Monad m => HsDecl -> m String+driftDerive' HsDataDecl { hsDeclName = name, hsDeclArgs = args, hsDeclCons = condecls, hsDeclDerives = derives } = do+        let d = unrenameTyVars $ toData  name args condecls derives+            isEnum = length condecls > 1 && null (concatMap hsConDeclArgs condecls)+        xs <- return $  map (derive isEnum d) derives+        return $ unlines xs+--driftDerive' (HsNewTypeDecl sloc cntxt name args condecl derives) = do+--        let d =  unrenameTyVars $ toData  name args [condecl] derives+--        xs <- return $ map (derive False d) derives+--        return $ unlines xs++driftDerive' _ = fail "Nothing to derive"++unrenameTyVars :: Data -> Data+unrenameTyVars d = d{+    vars = map (m Map.!) (vars d),+    constraints = map (\(c,v) -> (c, m Map.! v)) (constraints d)+  }+ where m = Map.fromList $ zip (vars d) tyVars+       tyVars = map (('a':) . show) [1::Int ..]++toData :: HsName -> [HsName] -> [HsConDecl] -> [HsName] -> Data+toData name args cons derives = ans where+    f c = Body { constructor = pp (getIdent $ hsConDeclName c), types = hsConDeclArgs c, labels = lb c }+    pp xs@(x:_) | isAlpha x = xs+    pp xs = '(':xs++")"+    lb HsConDecl {} = []+    lb  r = concatMap fst (hsConDeclRecArg r)+    ans = D { statement = DataStmt, vars = map show args, constraints = [], name = name,  derives = map show derives, body = map f cons }++derive True d wh | wh `elem` enumDerivableClasses ++ map toUnqualified enumDerivableClasses = "-- generated instance  " ++ show wh ++ " " ++ getIdent (name d)+derive _ d wh | Just fn <- Map.lookup wh standardRules = render $ fn d+              | Just _  <- Map.lookup (show wh) shortRuleNames = error (msg ++ " " ++ show wh ++ " not in scope.")+              | otherwise  = error msg+  where msg = "Can't make a derived instance '" ++ show wh ++ " " ++ getIdent (name d) ++ "'."++shortRuleNames = Map.mapKeys getIdent standardRules
+ src/DerivingDrift/RuleUtils.hs view
@@ -0,0 +1,106 @@+module DerivingDrift.RuleUtils (+    module Text.PrettyPrint.HughesPJ,+    module DerivingDrift.RuleUtils,+    module DerivingDrift.DataP+    )where++import DerivingDrift.DataP+import Name.Name(getIdent)+import Text.PrettyPrint.HughesPJ++x = text "x"+f = text "f"++rArrow = text "->"+lArrow = text "<-"+--equals = text "="+blank = text "_"+semicolon = char ';'++texts :: [String] -> [Doc]+texts = map text++block, blockList,parenList,bracketList :: [Doc] -> Doc+block = nest 4 . vcat+blockList = braces . fcat . sepWith semi+parenList = parens . fcat . sepWith comma+bracketList = brackets . fcat . sepWith comma++-- for bulding m1 >> m2 >> m3, f . g . h, etc+sepWith :: a -> [a] -> [a]+sepWith _ [] = []+sepWith a [x] = [x]+sepWith a (x:xs) = x:a: sepWith a xs++--optional combinator, applys fn if arg is non-[]+opt :: [a] -> ([a] -> Doc) -> Doc+opt [] f = empty+opt a f = f a++--equivalent of `opt' for singleton lists+opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc+opt1 [] _ _ = empty+opt1 [x] _ g = g x+opt1 a f g = f a++-- new simple docs+commentLine x = text "--" <+> x -- useful for warnings / error messages+commentBlock x = text "{-" <> x <> text "-}"++--- Utility Functions -------------------------------------------------------++-- Instances++-- instance header, handling class constraints etc.+simpleInstance :: Class -> Data -> Doc+simpleInstance s d = hsep [text "instance"+		, opt constr (\x -> parenList x <+> text "=>")+		, text s+		, opt1 (texts (getIdent (name d) : vars d)) parenSpace id]+   where+   constr = map (\(c,v) -> text c <+> text v) (constraints d) +++		      map (\x -> text s <+> text x) (vars d)+   parenSpace = parens . hcat . sepWith space++-- instanceSkeleton handles most instance declarations, where instance+-- functions are not related to one another.  A member function is generated+-- using a (IFunction,Doc) pair.  The IFunction is applied to each body of the+--  type, creating a block of pattern - matching cases. Default cases can be+-- given using the Doc in the pair.  If a default case is not required, set+-- Doc to 'empty'++type IFunction = Body -> Doc -- instance function++instanceSkeleton :: Class -> [(IFunction,Doc)] -> Data -> Doc+instanceSkeleton s ii  d = (simpleInstance s d <+> text "where")+				$$ block functions+	where+	functions = concatMap f ii+	f (i,dflt) = map i (body d) ++ [dflt]++-- little variable name generator, generates (length l) unique names aa - aZ+varNames :: [a] -> [Doc]+varNames l = take (length l) names+   where names = [text [x,y] | x <- ['a' .. 'z'],+                               y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+-- variant generating aa' - aZ'+varNames' :: [a] -> [Doc]+varNames' = map (<> (char '\'')) . varNames++-- pattern matching a constructor and args+pattern :: Constructor -> [a] -> Doc+pattern c l = parens $ fsep (text c : varNames l)++pattern_ :: Constructor -> [a] -> Doc+pattern_ c l = parens $ fsep (text c : replicate (length l) (text "_"))++pattern' :: Constructor -> [a] -> Doc+pattern' c l = parens $ fsep (text c : varNames' l)++-- test that a datatype has at least one record constructor+hasRecord :: Data -> Bool+hasRecord d =   statement d == DataStmt+		&& any (not . null . labels) (body d)++tuple :: [Doc] -> Doc+tuple xs = parens $ hcat (punctuate (char ',') xs)
+ src/DerivingDrift/StandardRules.hs view
@@ -0,0 +1,247 @@+module DerivingDrift.StandardRules (standardRules,driftResolvedNames) where++import DerivingDrift.RuleUtils+import Name.Prim+import Name.Name+import qualified Data.Map as Map++standardRules :: Map.Map Name.Name.Name (Data -> Doc)+standardRules = Map.fromList [+    (class_Eq,eqfn),+    (class_Ord,ordfn),+    (class_Enum,enumfn),+    (class_Show,showfn),+    (class_Read,readfn),+    (class_Bounded,boundedfn)]++-- this list is to be feeded to the renamer in the+-- renaming phase of the derived instances+driftResolvedNames :: [(Name.Name.Name,[Name.Name.Name])]+driftResolvedNames = map unkn stdCls ++ map self stdCls ++ map self stdVals+  where unkn n  = (toName UnknownType (q n), [n])+        self n  = (n,[n])+        stdCls  = Map.keys standardRules+        stdVals = [v_sub,v_compose,+                   dc_True,dc_False,v_and,+                   dc_EQ,v_equals,v_geq,v_gt,v_compare,+                   dc_Pair,+                   dc_EmptyList,dc_Cons,v_foldl,v_cat,v_drop,+                   v_showsPrec,v_showParen,v_showChar,v_showString,+                   v_readsPrec,v_readParen,v_lex,+                   v_fromEnum,v_toEnum,v_enumFrom,v_enumFromThen,+                   v_minBound,v_maxBound]++-- short for qualified and unqualified+q,u :: Name.Name.Name -> String+q = snd . fromName+u = getIdent++------------------------------------------------------------------------------+-- Rules for the derivable Prelude Classes++-- Eq++eqfn = instanceSkeleton (q class_Eq) [(makeEq,defaultEq)]++makeEq :: IFunction+makeEq (Body{constructor=constructor,types=types})+	| null types = hsep $ texts [constructor,u v_equals,constructor, "=", q dc_True]+	| otherwise = let+	v = varNames types+	v' = varNames' types+	d x = parens . hsep $ text constructor : x+	head = [ text (u v_equals), d v', text "="]+	body = sepWith (text $ q v_and) $+		zipWith (\x y -> (x <+> text (q v_equals) <+> y)) v v'+	in d v <+> fsep (head ++  body)++defaultEq = hsep $ texts ["_", u v_equals, "_", "=" ,q dc_False]++----------------------------------------------------------------------++-- Ord++ordfn d = let+   ifn = [f c c'+		| c <- zip (body d) [1 :: Int ..]+		, c' <- zip (body d) [1 :: Int ..]]+   cmp n n' = show $  compare n n'+   f (b,n) (b',n')+	| null (types b) = text (u v_compare) <+>+		   fsep [text (constructor b),+			 pattern (constructor b') (types b')+			, char '=', text $ cmp n n' ]+	| otherwise = let+		      head  = fsep [l,r, char '=']+		      l = pattern (constructor b) (types b)+		      r = pattern' (constructor b') (types b')+		      one x y = fsep [text (q v_compare),x,y]+		      list [x] [y] = one x y+		      list xs ys = fsep [text (q v_foldl), parens fn, text (q dc_EQ),+			           bracketList (zipWith one xs ys)]+		      fn = fsep $ texts  ["\\x y", "->", "if", "x", q v_equals, q dc_EQ,+			   "then", q v_compare, "y", q dc_EQ, "else", "x"]+		in if constructor b == constructor b' then+		    text (u v_compare) <+> fsep [head,+			     list (varNames $ types b) (varNames' $ types b')]+		   else  text (u v_compare) <+> fsep [head,text (cmp n n')]+    in simpleInstance (q class_Ord) d <+> text "where" $$ block ifn+++----------------------------------------------------------------------++-- Show & Read+-- 	won't work for infix constructors+--+-- Show++showfn = instanceSkeleton (q class_Show) [(makeShow,empty)]++makeShow :: IFunction+makeShow (Body{constructor=constructor,labels=labels,types=types})+	| null types = fnName <+> fsep [headfn,showString constructor]+	| null labels = fnName <+> fsep [headfn,bodyStart, body]   -- datatype+	| otherwise = fnName <+> fsep[headfn,bodyStart,recordBody] -- record+	where+	fnName = text (u v_showsPrec)+	headfn = fsep [char 'd',(pattern constructor types),equals]+	bodyStart = fsep [text (q v_showParen),parens $ fsep [text "d",text (q v_geq),text "10"]]+	body = parens . fsep $ sepWith s (c : b)+	recordBody = parens $ fsep [c,comp,showChar '{',comp,+				    fsep (sepWith s' b'),comp,showChar '}']+	c = showString constructor+	b = map (\x -> fsep[text (q v_showsPrec), text "10", x]) (varNames types)+	b' = zipWith (\x l -> fsep [showString l, comp, showString " = ", comp, x])+			            b (map getIdent labels)+	s = fsep [comp,showChar ' ', comp]+	s' = fsep [comp,showChar ',',comp]+	showChar c = fsep [text (q v_showChar), text ('\'':c:"\'")]+	showString s = fsep [text (q v_showString), doubleQuotes $ text s]+	comp = text (q v_compose)++-- Read++readfn d = simpleInstance (q class_Read) d <+> text "where" $$ readsPrecFn d++readsPrecFn d = let+	fnName = text (u v_readsPrec)+	bodies = vcat $ sepWith (text $ q v_cat) (map makeRead (body d))+	in nest 4 $ fnName <+> fsep[char 'd', text "input", equals,bodies]++makeRead :: IFunction+makeRead (Body{constructor=constructor,labels=labels,types=types})+	| null types = fsep [read0,text "input"]+	| null labels = fsep [headfn,read,text "input"]+	| otherwise = fsep [headfn,readRecord, text "input"]+	where+	headfn = fsep [text (q v_readParen), parens (text $ unwords ["d",q v_gt,"9"])]+	read0 = lambda $ listComp (result rest) [lexConstr rest]+	read = lambda . listComp (result rest)+		     $ lexConstr ip : ( map f (init vars) )+			++ final (last vars)+        f v = fsep [tup v ip, from,readsPrec, ip]+	final v = [fsep[tup v rest,from,readsPrec,ip]]+	readRecord = let+		f lab v = [+			fsep [tup (tshow $ show (toUnqualified lab)) ip,lex],+			fsep [tup (text $ show "=") ip,lex],+			fsep [tup v ip ,from,readsPrec,ip]]+		openB = fsep [tup (text $ show "{") ip,lex]+		closeB = fsep [tup (text $ show "}") rest,lex]+		comma = [fsep [tup (text $ show ",") ip,lex]]+		in lambda . listComp (result rest)+			$ lexConstr ip : openB+			: (concat . sepWith comma) (zipWith f labels vars)+			 ++ [closeB]+	lambda x = parens ( fsep [text "\\",ip,text "->",x])+	listComp x ~(l:ll) = brackets . fsep . sepWith comma $+				((fsep[x, char '|', l]) : ll)+	result x = tup (pattern constructor vars) x+	lexConstr x = fsep [tup (text $ show constructor) x, lex]+	-- nifty little bits of syntax+	vars = varNames types+	ip = text "inp"+	rest = text "rest"+	tup x y = parens $ fsep [x <> char ',', y]+	lex = fsep[from,text (q v_lex),ip]+	readsPrec = fsep [text (q v_readsPrec),text "10"]+	from = text "<-"+++tshow x = text (show x)+----------------------------------------------------------------------++-- Enum -- a lot of this code should be provided as default instances,+-- 	 but currently isn't++enumfn d = let+	fromE = fromEnumFn d+	toE = toEnumFn d+	eFrom = enumFromFn d+	in if any (not . null . types) (body d)+	   then commentLine $ text "Warning -- can't derive Enum for"+				<+> text (getIdent $ name d)+	   else simpleInstance (q class_Enum) d <+> text "where"+		$$ block (fromE ++ toE ++ [eFrom,enumFromThenFn])++fromEnumFn :: Data -> [Doc]+fromEnumFn (D{body=body}) = map f (zip body [0:: Int ..])+	where+	f (Body{constructor=constructor},x) = text (u v_fromEnum) <+> (fsep $+		texts [constructor , "=", show x])++toEnumFn :: Data -> [Doc]+toEnumFn (D{body=body}) = map f (zip body [0 :: Int ..])+	where+	f (Body{constructor=constructor},x) = text (u v_toEnum) <+> (fsep $+		texts [show x , "=", constructor])++enumFromFn :: Data -> Doc+enumFromFn D{body=body} = let+	conList = bracketList . texts . map constructor $ body+	bodydoc = fsep [char 'e', char '=', text (q v_drop),+		parens (text (q v_fromEnum) <+> char 'e'), conList]+	in text (u v_enumFrom) <+> bodydoc++enumFromThenFn ::  Doc+enumFromThenFn = let+	wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(",+		 q v_enumFrom, "i", ")"]+	eq1 = text "enumFromThen\'"+                <+> fsep (texts ["_","_",u dc_EmptyList,"=",u dc_EmptyList])+	eq2 = text "enumFromThen\'"+                <+> fsep (texts ["i","j","(x",u dc_Cons,"xs)","="])+                <+> fsep [hsep $ texts [+                           "let", "d", "=",+                                q v_fromEnum,"j",q v_sub,q v_fromEnum,"i"],+                          text "in" <+> fsep (texts [+                             "x",u dc_Cons,"enumFromThen\'","i","j","(", q v_drop]+                                ++ [parens . hsep $ texts ["d",q v_sub,"1"]]+                                ++ [text "xs",text ")"])]+	in text (q v_enumFromThen) <+> wrapper $$ block [text "where",eq1,eq2]++----------------------------------------------------------------------++-- Bounded - as if anyone uses this one :-) ..++boundedfn d@D{name=name,body=body,derives=derives}+	| all (null . types) body  = boundedEnum d+	| singleton body = boundedSingle d+       | otherwise = commentLine $ text "Warning -- can't derive Bounded for"+			<+> (text $ getIdent name)++boundedEnum d@D{body=body} = let f = constructor . head $ body+			         l = constructor . last $ body+	in simpleInstance (q class_Bounded) d <+> text "where" $$ block [+		hsep (texts [u v_minBound,"=",f]),+		hsep (texts [u v_maxBound,"=",l])]++boundedSingle d@D{body=body} = let f = head $ body+	in simpleInstance (q class_Bounded) d <+> text "where" $$ block [+		hsep . texts $ [u v_minBound,"=",constructor f] +++			replicate (length (types f)) (q v_minBound),+		hsep . texts $ [u v_maxBound,"=",constructor f] +++			replicate (length (types f)) (q v_maxBound)]++singleton [x] = True+singleton _ = False
+ src/Doc/Attr.hs view
@@ -0,0 +1,42 @@+module Doc.Attr(Attr(..), attrEmpty, ansi, html)  where++import Doc.DocLike+++data Attr d = Attr {+   attrBold :: d -> d,+   attrColor :: String -> d -> d+}++attrEmpty = Attr { attrBold = id, attrColor = \_ -> id }+++ansi,html :: DocLike d => (String -> d) -> Attr d++ansi oob = attrEmpty {+    attrBold = \x -> oob "\27[1m" <> x <> oob attrClear,+    attrColor = \c x -> oob ("\27[" ++ ansiColor c ++ "m") <> x <> oob attrClear+        }++html oob = attrEmpty {+    attrBold = \x -> oob "<b style=\"color: white\">" <> x <> oob "</b>",+    attrColor = \c x -> oob ("<span style=\"color: " ++ c ++ ";\">") <> x <> oob "</span>"+        }+++ansiColor "black" = "0;30"+ansiColor "red"  = "0;31"+ansiColor "green"  = "0;32"+ansiColor "yellow"  = "0;33"+ansiColor "blue"  = "0;94"+ansiColor "magenta" = "0;35"+ansiColor "cyan"  = "0;36"+ansiColor "white" = "0;37"+ansiColor "lightgreen"  = "0;92"+ansiColor "lightred"  = "0;91"+--ansiColor "brightblue"  = "0;94"+ansiColor _ = "0"++attrClear = "\27[0m"++
+ src/Doc/Chars.hs view
@@ -0,0 +1,71 @@+-- | A variety of useful constant documents representing many unicode characters.++module Doc.Chars where++import Data.Char(chr)+import Doc.DocLike++ulCorner, llCorner, urCorner, lrCorner, rTee, lTee, bTee, tTee, hLine,+ vLine, plus, s1, s9, diamond, ckBoard, degree, plMinus, bullet, lArrow,+ rArrow, dArrow, uArrow, board, lantern, block, s3, s7, lEqual, gEqual,+ pi, nEqual, sterling, coloncolon, alpha, beta, lambda, forall, exists,+ box, bot, bottom, top, pI, lAmbda, star, elem, notElem, and, or, sqoparen, sqcparen  :: TextLike a => a++ulCorner  = char $ chr 0x250C+llCorner = char $ chr 0x2514+urCorner = char $ chr 0x2510+lrCorner = char $ chr 0x2518+rTee     = char $ chr 0x2524+lTee     = char $ chr 0x251C+bTee     = char $ chr 0x2534+tTee     = char $ chr 0x252C+hLine    = char $ chr 0x2500+vLine    = char $ chr 0x2502+plus     = char $ chr 0x253C+s1       = char $ chr 0x23BA -- was: 0xF800+s9       = char $ chr 0x23BD -- was: 0xF804+diamond  = char $ chr 0x25C6+ckBoard  = char $ chr 0x2592+degree   = char $ chr 0x00B0+plMinus  = char $ chr 0x00B1+bullet   = char $ chr 0x00B7+lArrow   = char $ chr 0x2190+rArrow   = char $ chr 0x2192+dArrow   = char $ chr 0x2193+uArrow   = char $ chr 0x2191+board    = char $ chr 0x2591+lantern  = char $ chr 0x256C+block    = char $ chr 0x2588+s3       = char $ chr 0x23BB -- was: 0xF801+s7       = char $ chr 0x23BC -- was: 0xF803+lEqual   = char $ chr 0x2264+gEqual   = char $ chr 0x2265+pi       = char $ chr 0x03C0+nEqual   = char $ chr 0x2260+sterling = char $ chr 0x00A3++coloncolon = char $ chr 0x2237  -- ∷++alpha    = char $ chr 0x03b1  -- α+beta     = char $ chr 0x03b2  -- β+++lambda   = char $ chr 0x03bb  -- λ+forall   = char $ chr 0x2200  -- ∀+exists   = char $ chr 0x2203  -- ∃+box      = char $ chr 0x25a1  -- □++bot      = char $ chr 0x22a5  -- ⊥+bottom   = char $ chr 0x22a5  -- ⊥+top      = char $ chr 0x22a4  -- T+pI       = char $ chr 0x03a0+lAmbda   = char $ chr 0x039b  -- Λ  (capital λ)+and      = char $ chr 0x2227  -- ∧+or       = char $ chr 0x2228  -- ∨+star     = char $ chr 0x22c6+elem     = char $ chr 0x2208  -- ∈+notElem  = char $ chr 0x2209++sqoparen = char $ chr 0x3014  -- 〔+sqcparen = char $ chr 0x3015  --  〕+
+ src/Doc/DocLike.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE CPP,UndecidableInstances,OverlappingInstances #-}+module Doc.DocLike where++#include "hs_src_config.h"++-- arch-tag: a88f19fb-e18d-475f-b6d1-8da78676261a++import Control.Monad.Reader()+import qualified Text.PrettyPrint.HughesPJ as P++infixr 5 <$> -- ,<//>,<$>,<$$>+infixr 6 <>+infixr 6 <+>++class TextLike a where+    empty :: a+    text :: String -> a+    --string :: String -> a+    char :: Char -> a+    --char '\n' = string "\n"+    char x = text [x]+    empty = text ""++class (TextLike a) => DocLike a where+    (<>) :: a -> a -> a+    (<+>) :: a -> a -> a+    (<$>) :: a -> a -> a+    hsep :: [a] -> a+    hcat :: [a] -> a+    vcat :: [a] -> a+    tupled :: [a] -> a+    list :: [a] -> a+    semiBraces :: [a] -> a+    enclose :: a -> a -> a -> a+    encloseSep :: a -> a -> a -> [a] -> a++    hcat [] = empty+    hcat xs = foldr1 (<>) xs+    hsep [] = empty+    hsep xs = foldr1 (<+>) xs+    vcat [] = empty+    vcat xs = foldr1 (\x y -> x <> char '\n' <> y) xs+    x <+> y = x <> char ' ' <> y+    x <$> y = x <> char '\n' <> y+    encloseSep l r s ds = enclose l r (hcat $ punctuate s ds)+    enclose l r x   = l <> x <> r+    list            = encloseSep lbracket rbracket comma+    tupled          = encloseSep lparen   rparen  comma+    semiBraces      = encloseSep lbrace   rbrace  semi++------------------------+-- Basic building blocks+------------------------++tshow :: (Show a,DocLike b) => a -> b+tshow x = text (show x)++lparen,rparen,langle,rangle,+    lbrace,rbrace,lbracket,rbracket,squote,+    dquote,semi,colon,comma,space,dot,backslash,equals+    :: TextLike a => a+lparen          = char '('+rparen          = char ')'+langle          = char '<'+rangle          = char '>'+lbrace          = char '{'+rbrace          = char '}'+lbracket        = char '['+rbracket        = char ']'++squote          = char '\''+dquote          = char '"'+semi            = char ';'+colon           = char ':'+comma           = char ','+space           = char ' '+dot             = char '.'+backslash       = char '\\'+equals          = char '='++squotes x = enclose squote squote x+dquotes x = enclose dquote dquote x+parens x = enclose lparen rparen x+braces x = enclose lbrace rbrace x+brackets x = enclose lbracket rbracket x+angles x = enclose langle rangle x++-----------------------------------------------------------+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]+-----------------------------------------------------------+punctuate _ []      = []+punctuate _ [d]     = [d]+punctuate p (d:ds)  = (d <> p) : punctuate p ds++------------------+-- String instance+------------------+instance TextLike String where+    empty = ""+    text x = x++instance TextLike Char where+    empty = error "TextLike: empty char"+    char x = x+    text [ch] = ch+    text _ = error "TextLike: string to char"++instance DocLike String where+    a <> b = a ++ b+    a <+> b = a ++ " " ++ b++instance TextLike ShowS where+    empty = id+    text x = (x ++)+    char c = (c:)++instance DocLike ShowS where+    a <> b = a . b++instance (TextLike a, Monad m) => TextLike (m a) where+    empty = return empty+    char x = return (char x)+    text x = return (text x)++instance (DocLike a, Monad m,TextLike (m a)) => DocLike (m a) where+    a <$> b = do+        a <- a+        b <- b+        return (a <$> b)+    a <> b = do+        a <- a+        b <- b+        return (a <> b)+    a <+> b = do+        a <- a+        b <- b+        return (a <+> b)+    vcat xs = sequence xs >>= return . vcat+    hsep xs = sequence xs >>= return . hsep++---------------------+-- HughesPJ instances+---------------------++instance TextLike P.Doc where+    empty = P.empty+    text = P.text+    char = P.char++#if !HAS_MONOID_DOC+instance Monoid P.Doc where+    mappend = (P.<>)+    mempty = P.empty+    mconcat = P.hcat+#endif++instance DocLike P.Doc where+    (<>) = (P.<>)+    (<+>) = (P.<+>)+    (<$>) = (P.$$)+    hsep = P.hsep+    vcat = P.vcat++    --brackets = P.brackets+    --parens = P.parens++--------+-- simple instances to allow distribution of an environment+--------+--instance Monoid a => Monoid (b -> a) where+--    mempty = \_ -> mempty+--    mappend x y = \a -> mappend (x a) (y a)+--    mconcat xs = \a -> mconcat (map ($ a) xs)+--+--instance (DocLike a, Monoid (b -> a)) => DocLike (b -> a) where+--    parens x = \a -> parens (x a)+--    (<+>) x y = \a -> x a <+> y a
+ src/Doc/PPrint.hs view
@@ -0,0 +1,97 @@++-- | A Pretty printing class using multiparameter type classes for+-- maximal generality with some useful instances.+--+-- the pprinted type comes as the last argument so newtype deriving can be used+-- in more places.++module Doc.PPrint where++import Doc.DocLike+import qualified Data.Map as Map++{-+ - some useful fixities for comparison+ -+ - application left 10+ - infixr 9  .+ - infixr 8  ^, ^^, **+ - infixl 7  *  , /, `quot`, `rem`, `div`, `mod`+ - infixl 6  +, -+ - infixr 5  :+ - infix  4  ==, /=, <, <=, >=, >+ - infixr 3  &&+ - infixr 2  ||+ - infixl 1  >>, >>=+ - infixr 1  =<<+ - infixr 0  $, $!, `seq`+ -+ -}++data Assoc = AssocLeft | AssocRight | AssocNone+    deriving(Eq,Ord,Show)++class DocLike d => PPrint d a  where+    pprint ::  a -> d+    pprintAssoc :: Assoc -> Int -> a -> d++    pprintAssoc _ _ a = pprint a+    pprint a = pprintAssoc AssocNone (-1) a+++    pplist    ::  [a] -> d+    pplist    xs = brackets (hcat (punctuate comma (map pprint xs)))++pprintParen :: PPrint d a => a -> d+pprintParen = pprintPrec 11++pprintPrec n a = pprintAssoc AssocNone n  a++instance PPrint d a => PPrint d [a] where+    pprint  = pplist++instance DocLike d => PPrint d Char where+  pprint  = char+  pplist  = text++instance DocLike d => PPrint d Integer where+  pprint  = tshow++instance DocLike d => PPrint d Int where+  pprint  = tshow++instance DocLike d => PPrint d Float where+  pprint  = tshow++instance DocLike d => PPrint d Double where+  pprint  = tshow++instance DocLike d => PPrint d () where+    pprint () = text "()"++instance (PPrint d a, PPrint d b) => PPrint d (a,b) where+  pprint (x,y) = parens (hsep [pprint x <> comma, pprint y])++checkAssoc a1 n1 a2 n2 | n2 < n1 = id+                       | n1 == n2 && a1 == a2 && a1 /= AssocNone = id+                       | otherwise = parens++checkAssocApp a n p = checkAssoc AssocLeft 10 a n p++pprintBinary a1 n1 a2 n2 x1 b x2 = checkAssoc a1 n1 a2 n2 $ pprintAssoc l n1 x1 <+> b <+> pprintAssoc r n1 x2 where+    l = if a1 == AssocLeft then AssocLeft else AssocNone+    r = if a1 == AssocRight then AssocRight else AssocNone++instance (PPrint d a, PPrint d b) => PPrint d (Either a b) where+  pprintAssoc a n (Left x)  = checkAssocApp a n $ text "Left" <+> pprintPrec 10 x+  pprintAssoc a n (Right x) = checkAssocApp a n $ text "Right" <+> pprintPrec 10 x++instance (PPrint d a, PPrint d b, PPrint d c) => PPrint d (a,b,c) where+  pprint (x,y,z) = parens (hsep [pprint x <> comma,+                                pprint y <> comma,+                                pprint z])++instance (PPrint d a, PPrint d b) => PPrint d (Map.Map a b) where+    pprint m = vcat [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m]++
+ src/Doc/Pretty.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+-----------------------------------------------------------+-- Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan+-- modified by John Meacham 2003+--+--+-- Pretty print module based on Philip Wadlers "prettier printer"+--      "A prettier printer"+--      Draft paper, April 1997, revised March 1998.+--      http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps+--+-- Haskell98 compatible+-----------------------------------------------------------++-- | Modification od Daan Leijens pretty printer. main changes are use of+-- Doc.DocLike framework and the addition of out-of-band data for html tags+-- or ansi escape codes++module Doc.Pretty+        ( Doc++        , putDoc, hPutDoc+        , putDocM, putDocMLn+        --, (<>)+        --, (<+>)+        , (</>), (<//>)+        --, (<$>)+        , (<$$>)++        , sep, fillSep, hsep, vsep+        , cat, fillCat, hcat, DocLike.vcat++        , align, hang, indent+        , fill, fillBreak+        , errorDoc, failDoc++       -- , string, bool, int, integer, float, double, rational++        , softline, softbreak+        , line, linebreak, nest, group+        , column, nesting, width++        , SimpleDoc(..)+        , renderPretty, renderCompact+        , displayS, displayIO, displayM+        , textProc, oob+        ) where++import System.IO      (Handle,hPutStr,hPutChar,stdout)+import Doc.DocLike hiding(empty)+import qualified Doc.DocLike as DocLike+import Data.Monoid(Monoid(..))++infixr 5 </>,<//>,<$$>+--infixr 6 <>,<+>+++-----------------------------------------------------------+-- list, tupled and semiBraces pretty print a list of+-- documents either horizontally or vertically aligned.+-----------------------------------------------------------++encloseSep left right sep ds+    = case ds of+        []  -> left <> right+        [d] -> left <> d <> right+        _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)++++errorDoc :: Doc -> a+errorDoc = error . ('\n':) . show++failDoc :: Monad m => Doc -> m a+failDoc = fail . ('\n':) . show++-----------------------------------------------------------+-- high-level combinators+-----------------------------------------------------------+sep             = group . vsep+fillSep         = fold (</>)+--hsep            = fold (<+>)+vsep            = fold (Doc.Pretty.<$>)++cat             = group . Doc.Pretty.vcat+fillCat         = fold (<//>)+--hcat            = fold (<>)+vcat            = fold (<$$>)++fold f []       = empty+fold f ds       = foldr1 f ds++instance Monoid Doc where+    mempty = Doc.Pretty.empty+    mappend = beside+    mconcat = fold beside++instance TextLike Doc where+    empty = Doc.Pretty.empty+    text = mytext+    char x = mychar x++instance DocLike Doc where+    x <> y = x `beside` y+    x <+> y = x <> space <> y+    encloseSep = Doc.Pretty.encloseSep+    vcat = Doc.Pretty.vcat+    --hcat = Doc.Pretty.hcat+    --hsep = Doc.Pretty.hsep++--x <> y          = x `beside` y+--x <+> y         = x <> space <> y+x </> y         = x <> softline <> y+x <//> y        = x <> softbreak <> y+x <$> y         = x <> line <> y+x <$$> y        = x <> linebreak <> y++softline        = group line+softbreak       = group linebreak++++-----------------------------------------------------------+-- Combinators for prelude types+-----------------------------------------------------------++{-+-- string is like "text" but replaces '\n' by "line"+string ""       = empty+string ('\n':s) = line <> string s+string s        = case (span (/='\n') s) of+                    (xs,ys) -> text xs <> string ys+++bool :: Bool -> Doc+bool b          = text (show b)++int :: Int -> Doc+int i           = text (show i)++integer :: Integer -> Doc+integer i       = text (show i)++float :: Float -> Doc+float f         = text (show f)++double :: Double -> Doc+double d        = text (show d)++rational :: Rational -> Doc+rational r      = text (show r)+-}++++-----------------------------------------------------------+-- semi primitive: fill and fillBreak+-----------------------------------------------------------+fillBreak f x   = width x (\w ->+                  if (w > f) then nest f linebreak+                             else text (spaces (f - w)))++fill f d        = width d (\w ->+                  if (w >= f) then empty+                              else text (spaces (f - w)))++width d f       = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))+++-----------------------------------------------------------+-- semi primitive: Alignment and indentation+-----------------------------------------------------------+indent i d      = hang i (text (spaces i) <> d)++hang i d        = align (nest i d)++align d         = column (\k ->+                  nesting (\i -> nest (k - i) d))   --nesting might be negative :-)++++-----------------------------------------------------------+-- Primitives+-----------------------------------------------------------+data Doc        = Empty+                | Char Char             -- invariant: char is not '\n'+                | Text !Int String      -- invariant: text doesn't contain '\n'+                | Line !Bool            -- True <=> when undone by group, do not insert a space+                | Cat Doc Doc+                | Nest !Int Doc+                | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc+                | Column  (Int -> Doc)+                | Nesting (Int -> Doc)++data SimpleDoc  = SEmpty+                | SChar Char SimpleDoc+                | SText !Int String SimpleDoc+                | SLine !Int SimpleDoc+{-+class IsDoc z where+    empty :: z+    char :: Char -> z+    text :: String -> z+    oob :: String -> z+    textProc :: (Char -> String) -> String -> z+    line :: z+    linebreak :: z+    beside :: z -> z -> z+    nest :: Int -> z -> z+    column :: (Int -> z) -> z+    nesting :: (Int -> z) -> z+    group :: ()+  -}+empty           = Empty++mychar '\n'       = line+mychar c          = Char c++mytext ""         = Empty+mytext s          = Text (length s) s++-- | out of band data. This text will appear in the pretty printed output but+-- won't count towards formatting, as far as pretty printing is concerned, it+-- is of length 0.++oob :: String -> Doc+oob "" = Empty+oob s = Text 0 s++textProc :: (Char -> String) -> String -> Doc+textProc f "" = Empty+textProc f s = Text (length s) $ concatMap f s++line            = Line False+linebreak       = Line True++beside x y      = Cat x y+nest i x        = Nest i x+column f        = Column f+nesting f       = Nesting f+group :: Doc -> Doc+group x         = Union (flatten x) x++flatten :: Doc -> Doc+flatten (Cat x y)       = Cat (flatten x) (flatten y)+flatten (Nest i x)      = Nest i (flatten x)+flatten (Line break)    = if break then Empty else Text 1 " "+flatten (Union x y)     = flatten x+flatten (Column f)      = Column (flatten . f)+flatten (Nesting f)     = Nesting (flatten . f)+flatten other           = other                     --Empty,Char,Text++++-----------------------------------------------------------+-- Renderers+-----------------------------------------------------------++-----------------------------------------------------------+-- renderPretty: the default pretty printing algorithm+-----------------------------------------------------------++-- list of indentation/document pairs; saves an indirection over [(Int,Doc)]+data Docs   = Nil+            | Cons !Int Doc Docs++renderPretty :: Float -> Int -> Doc -> SimpleDoc+renderPretty rfrac w x+    = best 0 0 (Cons 0 x Nil)+    where+      -- r :: the ribbon width in characters+      r  = max 0 (min w (round (fromIntegral w * rfrac)))++      -- best :: n = indentation of current line+      --         k = current column+      --        (ie. (k >= n) && (k - n == count of inserted characters)+      best n k Nil      = SEmpty+      best n k (Cons i d ds)+        = case d of+            Empty       -> best n k ds+            Char c      -> let k' = k+1 in seq k' (SChar c (best n k' ds))+            Text l s    -> let k' = k+l in seq k' (SText l s (best n k' ds))+            Line _      -> SLine i (best i i ds)+            Cat x y     -> best n k (Cons i x (Cons i y ds))+            Nest j x    -> let i' = i+j in seq i' (best n k (Cons i' x ds))+            Union x y   -> nicest n k (best n k (Cons i x ds))+                                      (best n k (Cons i y ds))++            Column f    -> best n k (Cons i (f k) ds)+            Nesting f   -> best n k (Cons i (f i) ds)++      --nicest :: r = ribbon width, w = page width,+      --          n = indentation of current line, k = current column+      --          x and y, the (simple) documents to chose from.+      --          precondition: first lines of x are longer than the first lines of y.+      nicest n k x y    | fits width x  = x+                        | otherwise     = y+                        where+                          width = min (w - k) (r - k + n)+++fits w x        | w < 0         = False+fits w SEmpty                   = True+fits w (SChar c x)              = fits (w - 1) x+fits w (SText l s x)            = fits (w - l) x+fits w (SLine i x)              = True+++-----------------------------------------------------------+-- renderCompact: renders documents without indentation+--  fast and fewer characters output, good for machines+-----------------------------------------------------------+renderCompact :: Doc -> SimpleDoc+renderCompact x+    = scan 0 [x]+    where+      scan k []     = SEmpty+      scan k (d:ds) = case d of+                        Empty       -> scan k ds+                        Char c      -> let k' = k+1 in seq k' (SChar c (scan k' ds))+                        Text l s    -> let k' = k+l in seq k' (SText l s (scan k' ds))+                        Line _      -> SLine 0 (scan 0 ds)+                        Cat x y     -> scan k (x:y:ds)+                        Nest j x    -> scan k (x:ds)+                        Union x y   -> scan k (y:ds)+                        Column f    -> scan k (f k:ds)+                        Nesting f   -> scan k (f 0:ds)++++-----------------------------------------------------------+-- Displayers:  displayS and displayIO+-----------------------------------------------------------+displayS :: SimpleDoc -> ShowS+displayS SEmpty             = id+displayS (SChar c x)        = showChar c . displayS x+displayS (SText l s x)      = showString s . displayS x+displayS (SLine i x)        = showString ('\n':indentation i) . displayS x++displayIO :: Handle -> SimpleDoc -> IO ()+displayIO handle simpleDoc+    = display simpleDoc+    where+      display SEmpty        = return ()+      display (SChar c x)   = do{ hPutChar handle c; display x}+      display (SText l s x) = do{ hPutStr handle s; display x}+      display (SLine i x)   = do{ hPutStr handle ('\n':indentation i); display x}++displayM :: Monad m => (String -> m ()) -> SimpleDoc -> m ()+displayM putStr simpleDoc = display simpleDoc where+      display SEmpty        = return ()+      display (SChar c x)   = do{ putStr [c]; display x}+      display (SText l s x) = do{ putStr s; display x}+      display (SLine i x)   = do{ putStr ('\n':indentation i); display x}++-----------------------------------------------------------+-- default pretty printers: show, putDoc and hPutDoc+-----------------------------------------------------------+instance Show Doc where+  showsPrec d doc       = displayS (renderPretty 0.4 80 doc)++putDoc :: Doc -> IO ()+putDoc doc              = hPutDoc stdout doc++putDocM :: Monad m => (String -> m ()) -> Doc -> m ()+putDocM putStr d = displayM putStr (renderPretty 0.4 80 d)++putDocMLn :: Monad m => (String -> m ()) -> Doc -> m ()+putDocMLn putStr d = displayM putStr (renderPretty 0.4 80 d) >> putStr "\n"++hPutDoc :: Handle -> Doc -> IO ()+hPutDoc handle doc      = displayIO handle (renderPretty 0.4 80 doc)++++-----------------------------------------------------------+-- insert spaces+-- "indentation" used to insert tabs but tabs seem to cause+-- more trouble than they solve :-)+-----------------------------------------------------------+spaces n        | n <= 0    = ""+                | otherwise = replicate n ' '++indentation n   = spaces n++--indentation n   | n >= 8    = '\t' : indentation (n-8)+--                | otherwise = spaces n
+ src/E/Annotate.hs view
@@ -0,0 +1,156 @@+module E.Annotate where++import Control.Monad.Reader+import Data.Monoid+import qualified Data.Traversable as T++import E.E+import E.Program+import E.Subst+import GenUtil+import Info.Info(Info)+import Name.Id+import Util.HasSize+import Util.SetLike++annotateCombs :: forall m . Monad m =>+    (IdMap (Maybe E))+    -> (Id -> Info -> m Info)   -- ^ annotate based on Id map+    -> (E -> Info -> m Info)    -- ^ annotate letbound bindings+    -> (E -> Info -> m Info)    -- ^ annotate lambdabound bindings+    -> [Comb]                   -- ^ terms to annotate+    -> m [Comb]++annotateCombs imap idann letann lamann cs = do+    cs <- forM cs $ \comb -> do+        nfo <- letann (combBody comb) (tvrInfo $ combHead comb)+        nt <- annotate imap idann letann lamann (tvrType  $ combHead comb)+        return $ combHead_u (tvrInfo_s nfo . tvrType_s nt) comb+    let nimap = fromList [ (combIdent c, Just . EVar $ combHead c) | c <- cs ]+            `mappend` imap+        f :: (IdMap (Maybe E)) -> E -> m E+        f ni e = annotate ni idann letann lamann e+    let mrule :: Rule -> m Rule+        mrule r = do+            let g tvr = do+                nfo <- idann (tvrIdent tvr) (tvrInfo tvr)+                let ntvr = tvr { tvrInfo = nfo }+                return (ntvr,minsert (tvrIdent tvr) (Just $ EVar ntvr))+            bs <- mapM g $ ruleBinds r+            let nnimap = (foldr (.) id $ snds bs) nimap :: IdMap (Maybe E)+            args <- mapM (f nnimap) (ruleArgs r)+            body <- (f nnimap) (ruleBody r)+            return r { ruleBinds = fsts bs, ruleBody = body, ruleArgs = args }+    forM cs $ \comb -> do+        rs <- mapM mrule (combRules comb)+        nb <- f nimap (combBody comb)+        return . combRules_s rs . combBody_s nb $ comb++annotateDs :: Monad m =>+    (IdMap (Maybe E))+    -> (Id -> Info -> m Info)  -- ^ annotate based on Id map+    -> (E -> Info -> m Info)   -- ^ annotate letbound bindings+    -> (E -> Info -> m Info)   -- ^ annotate lambdabound bindings+    -> [(TVr,E)]               -- ^ terms to annotate+    -> m [(TVr,E)]++annotateDs imap idann letann lamann ds = do+    ELetRec { eDefs = ds', eBody = Unknown } <- annotate imap idann letann lamann (ELetRec ds Unknown)+    return ds'++annotateProgram :: Monad m =>+    (IdMap (Maybe E))+    -> (Id -> Info -> m Info)   -- ^ annotate based on Id map+    -> (E -> Info -> m Info)    -- ^ annotate letbound bindings+    -> (E -> Info -> m Info)    -- ^ annotate lambdabound bindings+    -> Program                  -- ^ terms to annotate+    -> m Program+annotateProgram imap idann letann lamann prog = do+    ds <- annotateCombs imap idann letann lamann (progCombinators prog)+    return $ programUpdate $ prog { progCombinators = ds }++type AM m = ReaderT (IdMap (Maybe E)) m++annotate :: Monad m =>+    (IdMap (Maybe E))+    -> (Id -> Info -> m Info)   -- ^ annotate based on Id map+    -> (E -> Info -> m Info)    -- ^ annotate letbound bindings+    -> (E -> Info -> m Info)    -- ^ annotate lambdabound bindings+    ->  E                       -- ^ term to annotate+    -> m E+annotate imap idann letann lamann e = runReaderT (f e) imap where+    f eo@(EVar tvr@(TVr { tvrIdent = i, tvrType =  t })) = do+        mp <- ask+        case mlookup i mp of+          Just (Just v) -> return v+          _  -> return eo+    f (ELam tvr e) = lp ELam tvr e+    f (EPi tvr e) = lp EPi tvr e+    f (EAp a b) = liftM2 EAp (f a) (f b)+    f (EError x e) = liftM (EError x) (f e)+    f (EPrim x es e) = liftM2 (EPrim x) (mapM f es) (f e)+    f ELetRec { eDefs = dl, eBody = e } = do+        dl' <- flip mapM dl $ \ (t,e) -> do+            nfo <- lift $ letann e (tvrInfo t)+            return t { tvrInfo = nfo }+        (as,rs) <- liftM unzip $ mapMntvr dl'+        local (foldr (.) id rs) $ do+            ds <- mapM f (snds dl)+            e' <- f e+            return $ ELetRec (zip as ds) e'+    f (ELit l) = liftM ELit $ litSMapM f l+    f Unknown = return Unknown+    f e@(ESort {}) = return e+    f ec@(ECase {}) = do+        e' <- f $ eCaseScrutinee ec+        let caseBind = eCaseBind ec+        (b',r) <- ntvr [] caseBind+        d <- local r $ T.mapM f $ eCaseDefault ec+        let da (Alt lc@LitCons { litName = s, litArgs = vs, litType = t } e) = do+                t' <- f t+                (as,rs) <- liftM unzip $ mapMntvr vs+                e' <- local (foldr (.) id rs) $ f e+                return $ Alt lc { litArgs = as, litType = t' } e'+            da (Alt l e) = do+                l' <- T.mapM f l+                e' <- f e+                return $ Alt l' e'+        alts <- local r (mapM da $ eCaseAlts ec)+        t' <- f (eCaseType ec)+        return $ caseUpdate ECase { eCaseAllFV = error "no eCaseAllFV needed",  eCaseScrutinee = e', eCaseType = t', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts }+    lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == emptyId  = do+        t' <- f t+        nfo <- lift $ lamann e (tvrInfo tvr)+        nfo <- lift $ idann n nfo+        e' <- local (minsert n Nothing) $ f e+        return $ lam (tvr { tvrIdent = emptyId, tvrType =  t', tvrInfo =  nfo}) e'+    lp lam tvr e = do+        nfo <- lift $ lamann e (tvrInfo tvr)+        (tv,r) <- ntvr  [] tvr { tvrInfo = nfo }+        e' <- local r $ f e+        return $ lam tv e'+    mapMntvr ts = f ts [] where+        f [] xs = return $ reverse xs+        f (t:ts) rs = do+            (t',r) <- ntvr vs t+            local r $ f ts ((t',r):rs)+        vs = [ tvrIdent x | x <- ts ]+    ntvr xs tvr@(TVr { tvrIdent = n, tvrType =  t}) | n == emptyId = do+        t' <- f t+        nfo <- lift $ idann emptyId (tvrInfo tvr)+        let nvr = (tvr { tvrType =  t', tvrInfo = nfo})+        return (nvr,id)+    ntvr xs tvr@(TVr {tvrIdent = i, tvrType =  t}) = do+        t' <- f t+        ss <- ask+        nfo' <- lift $ idann i (tvrInfo tvr)+        let i' = mnv xs i ss+        let nvr = (tvr { tvrIdent =  i', tvrType =  t', tvrInfo =  nfo'})+        case i == i' of+            True -> return (nvr,minsert i (Just $ EVar nvr))+            False -> return (nvr,minsert i (Just $ EVar nvr) . minsert i' Nothing)++mnv xs i ss+    | isInvalidId i || i `member` ss  = newId (size ss) isOkay+    | otherwise = i+    where isOkay i = (i `notMember` ss) && (i `notElem` xs)
+ src/E/Arbitrary.hs view
@@ -0,0 +1,151 @@+module E.Arbitrary where++--import Test.QuickCheck+import Data.Monoid+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty (putDoc, Doc)+import E.E+import E.Show+import E.TypeCheck()+import GenUtil+import Name.Id+import Name.VConsts+import Random+import Support.CanType+import Support.FreeVars+import qualified Data.Map as Map+import qualified Data.Set as Set++data EP = EP {+    canDiverge :: Bool,+    usedVars :: Set.Set TVr+    }++choose :: [IO a] -> IO a+choose [] = fail "nothing to choose from"+choose as = do+    x <- randomRIO (0,length as - 1)+    as !! x++value t+    | t == tInteger = choose [return $ ELit $ LitInt 1 tInteger]+    | t == tChar = choose [return $ ELit $ LitInt (fromIntegral (fromEnum 'x')) tChar]+    | t == eStar = choose $ map return [tChar, tInteger]++var t = do+    x <- randomRIO (1,100)+    return $ TVr (anonymous x) t mempty++complicate :: Set.Set TVr -> E -> IO E+complicate fvs e = do+    let re = if Set.null fvs then (replicate 1 (return e) ++ ) else id+    e <- choose  $ re  (replicate 2 $ complicate' fvs e >>= complicate fvs )+    return e++complicate' fvs e+    | EPi (TVr _ a1 _) a2 <- te = choose [ do v <- value a1; return (EAp e v), f e  ]+    | otherwise = f e+    where+    te = getType e+    f (EAp a b) = choose [do+        a' <- complicate fvs a+        b' <- complicate fvs b+        return (EAp a b), g e]+    f (ELam v e) = choose [do+            e' <- complicate fvs e+            return (ELam v e'),+            g e]+    f e = g e+    g e = do+        t <- value eStar+        v <- var t+        return (ELam v e)++genE = do+    v <- value tInteger+    complicate mempty v++ge = do+    e <- genE+    print e+    putStrLn (render $ (ePretty e :: Doc))+    putDoc (pprint (getType e))++testE = do+    putStrLn "Testing E"+    ge+    ge++{-++typeSet env = Map.keys env+typeCnt env a+    | Just x <- Map.lookup a env = x+    | otherwise = 0+typeCntInc env a = Map.insert a (typeCnt env a + 1) env++countTerm :: E -> Map.Map E Int -> Int -> Int+countTerm _t _env 0 = 0+countTerm t env 1 = typeCnt env t+countTerm t@(EPi (TVr _ a1 _) a2) env s = countTerm a2 (typeCntInc env a1) (s - 1) + countHeadVarTerm t env s+countTerm t env s = countHeadVarTerm t env s++countHeadVarTerm t env s = sum [ countHeadVarArgTerms bs env s | bs <- validHeadVarTypeSet t env]++countHeadVarArgTerms (b,bs) env s+    | numVarWithTypeInEnv <= 0 = 0    -- multiplication is too strict here+    | otherwise = numVarWithTypeInEnv * numTerms where+        numVarWithTypeInEnv = typeCnt env b+        m = length bs+        numTerms = sum [ product [ countTerm b env s | s <- ss | b <- bs ] | ss <- ndk (s - 1 - m) m]++validHeadVarTypeSet  a env = concat (map (f []) (Map.keys env)) where+    f rs b | b == a = return (a,reverse rs)+    f rs (EPi (TVr _ b1 _) b2) = f (b1:rs) b2+    f _ _ = fail "not valid head var type set"++ndk :: Int -> Int -> [[Int]]+ndk n m | n < 0 = error "ndk: n < 0"+ndk n m | m < 0 = error "ndk: m < 0"+ndk n m | n < m = error "ndk: n < m"+ndk 0 m = []+ndk n m | n == m = [replicate m 1]+ndk n m = snub $ concat [ f ss | ss <- ndk (n - 1) m] where+    f ss = [ [ if i == i' then s + 1 else s | s <- ss | i' <- [0 :: Int ..] ] | _ <- ss | i <- [0 :: Int ..] ]++testE = do+    putStrLn "Testing E"+    let f x i = do+        putStrLn $ "countTerm" <+> show x <+> show i <+> "=" <+> show (countTerm x (Map.singleton eStar 1) i)+    f eStar 2+    f eStar 4+    f eStar 1+    f (ePi (TVr 0 eStar mempty) eStar) 7+    let prop_ndk n m = abs n >= abs m ==> let ss = ndk (abs n) (abs m) in and [ sum s == (abs n) |s <- ss] && unique mempty ss where+        unique _ [] = True+        unique ss (x:xs) | x `Set.member` ss = False+        unique ss (x:xs) = unique (Set.insert x ss) xs+    --quickCheck prop_ndk++    print (ndk 4 2)+    --print (ndk 10 4)++gen a s = genTerm a mempty s++genTerm _a _env s | s < 1 = return Nothing+genTerm a env 1+    | typeCnt env a > 0 = genVarTerm env a+    | otherwise = return Nothing+genTerm (EPi (TVr _ a1) a2) env s = do+    let totalNumTerm = countTerm a env s+        numLamTerm = countTerm a2 (typeCntInc env a1 (s - 1))+    x <- randomRIO (0,totalNumTerm)+    if x <= numLamTerm then+        genLamTerm a1 a2 env s+      else genAppTerm a env s (totalNumTerm  - numLamTerm)+genTerm a env s = genAppTerm a env s (countTerm a env s)++genVarTerm a env | typeCnt env a == 0 = return Nothing++-}
+ src/E/Binary.hs view
@@ -0,0 +1,232 @@+module E.Binary() where++import Data.Binary+import E.Type+import FrontEnd.HsSyn()+import Name.Binary()+import {-# SOURCE #-} Info.Binary(putInfo,getInfo)++instance Binary TVr where+    put TVr { tvrIdent = eid, tvrType =  e, tvrInfo = nf} = do+        put eid+        put e+        putInfo nf+    get  = do+        x <- get+        e <- get+        nf <- getInfo+        return $ TVr x e nf++instance Data.Binary.Binary RuleType where+    put RuleSpecialization = do+	    Data.Binary.putWord8 0+    put RuleUser = do+	    Data.Binary.putWord8 1+    put RuleCatalyst = do+	    Data.Binary.putWord8 2+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return RuleSpecialization+	      1 -> do+		    return RuleUser+	      2 -> do+		    return RuleCatalyst+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary Rule where+    put (Rule aa ab ac ad ae af ag ah) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+	    Data.Binary.put ae+	    Data.Binary.put af+	    Data.Binary.put ag+	    Data.Binary.put ah+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    ae <- get+    af <- get+    ag <- get+    ah <- get+    return (Rule aa ab ac ad ae af ag ah)++instance Data.Binary.Binary ARules where+    put (ARules aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (ARules aa ab)++instance (Data.Binary.Binary e,+	  Data.Binary.Binary t) => Data.Binary.Binary (Lit e t) where+    put (LitInt aa ab) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+    put (LitCons ac ad ae af) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ac+	    Data.Binary.put ad+	    Data.Binary.put ae+	    Data.Binary.put af+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    return (LitInt aa ab)+	      1 -> do+		    ac <- Data.Binary.get+		    ad <- Data.Binary.get+		    ae <- Data.Binary.get+		    af <- Data.Binary.get+		    return (LitCons ac ad ae af)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary ESort where+    put EStar = do+	    Data.Binary.putWord8 0+    put EBang = do+	    Data.Binary.putWord8 1+    put EHash = do+	    Data.Binary.putWord8 2+    put ETuple = do+	    Data.Binary.putWord8 3+    put EHashHash = do+	    Data.Binary.putWord8 4+    put EStarStar = do+	    Data.Binary.putWord8 5+    put (ESortNamed aa) = do+	    Data.Binary.putWord8 6+	    Data.Binary.put aa+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    return EStar+	      1 -> do+		    return EBang+	      2 -> do+		    return EHash+	      3 -> do+		    return ETuple+	      4 -> do+		    return EHashHash+	      5 -> do+		    return EStarStar+	      6 -> do+		    aa <- Data.Binary.get+		    return (ESortNamed aa)+	      _ -> fail "invalid binary data found"++instance Data.Binary.Binary E where+    put (EAp aa ab) = do+	    Data.Binary.putWord8 0+	    Data.Binary.put aa+	    Data.Binary.put ab+    put (ELam ac ad) = do+	    Data.Binary.putWord8 1+	    Data.Binary.put ac+	    Data.Binary.put ad+    put (EPi ae af) = do+	    Data.Binary.putWord8 2+	    Data.Binary.put ae+	    Data.Binary.put af+    put (EVar ag) = do+	    Data.Binary.putWord8 3+	    Data.Binary.put ag+    put Unknown = do+	    Data.Binary.putWord8 4+    put (ESort ah) = do+	    Data.Binary.putWord8 5+	    Data.Binary.put ah+    put (ELit ai) = do+	    Data.Binary.putWord8 6+	    Data.Binary.put ai+    put (ELetRec aj ak) = do+	    Data.Binary.putWord8 7+	    Data.Binary.put aj+	    Data.Binary.put ak+    put (EPrim al am an) = do+	    Data.Binary.putWord8 8+	    Data.Binary.put al+	    Data.Binary.put am+	    Data.Binary.put an+    put (EError ao ap) = do+	    Data.Binary.putWord8 9+	    Data.Binary.put ao+	    Data.Binary.put ap+    put (ECase aq ar as at au av) = do+	    Data.Binary.putWord8 10+	    Data.Binary.put aq+	    Data.Binary.put ar+	    Data.Binary.put as+	    Data.Binary.put at+	    Data.Binary.put au+	    Data.Binary.put av+    get = do+	    h <- Data.Binary.getWord8+	    case h of+	      0 -> do+		    aa <- Data.Binary.get+		    ab <- Data.Binary.get+		    return (EAp aa ab)+	      1 -> do+		    ac <- Data.Binary.get+		    ad <- Data.Binary.get+		    return (ELam ac ad)+	      2 -> do+		    ae <- Data.Binary.get+		    af <- Data.Binary.get+		    return (EPi ae af)+	      3 -> do+		    ag <- Data.Binary.get+		    return (EVar ag)+	      4 -> do+		    return Unknown+	      5 -> do+		    ah <- Data.Binary.get+		    return (ESort ah)+	      6 -> do+		    ai <- Data.Binary.get+		    return (ELit ai)+	      7 -> do+		    aj <- Data.Binary.get+		    ak <- Data.Binary.get+		    return (ELetRec aj ak)+	      8 -> do+		    al <- Data.Binary.get+		    am <- Data.Binary.get+		    an <- Data.Binary.get+		    return (EPrim al am an)+	      9 -> do+		    ao <- Data.Binary.get+		    ap <- Data.Binary.get+		    return (EError ao ap)+	      10 -> do+		    aq <- Data.Binary.get+		    ar <- Data.Binary.get+		    as <- Data.Binary.get+		    at <- Data.Binary.get+		    au <- Data.Binary.get+		    av <- Data.Binary.get+		    return (ECase aq ar as at au av)+	      _ -> fail "invalid binary data found"++instance (Data.Binary.Binary e) => Data.Binary.Binary (Alt e) where+    put (Alt aa ab) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+    get = do+    aa <- get+    ab <- get+    return (Alt aa ab)
+ src/E/Diff.hs view
@@ -0,0 +1,40 @@+-- | Attempt to find pretty printable differences between terms.++module E.Diff where++import E.E+import E.FreeVars()+import E.Traverse+import Stats+import Support.FreeVars++-- | take two expressions and return (hopefully smaller) expressions with their differences++diff ::  E -> E -> (E,E)+diff a b = f a b where+    f (ELetRec ds e) (ELetRec ds' e') = (ELetRec (g ds ds') e, ELetRec (g ds' ds) e')+    f a b = (a,b)+    g ds ds' = [ d | d@(v,e) <- ds, not (lookup v ds' == Just e)  ]++-- show terms which contain interesting free variables+findOddFreeVars  :: [TVr] -> E -> E+findOddFreeVars fs (ELetRec ds e) = ELetRec [ ds | ds@(_,e) <- ds, any (`elem` fs) (freeVars e) ] e+findOddFreeVars _ e = e++printEStats :: E -> IO ()+printEStats e = do+    stats <- Stats.new+    let f e@ELam {} = tick stats "lambda" >> emapE' f e+        f e@EVar {} = tick stats "var-use" >> return e+        f e@(ELetRec ds _) = ticks stats (length ds) "let-binding" >> emapE' f e+        f e@EPi {} = tick stats "pi" >> emapE' f e+        f e@ELit {} = tick stats "lit" >> emapE' f e+        f e@EPrim {} = tick stats "prim" >> emapE' f e+        f e@EError {} = tick stats "error" >> emapE' f e+        f e@ECase {} = do+            tick stats "case"+            ticks stats (length $ caseBodies e) "case-alt"+            emapE' f e+        f e = tick stats "other" >> emapE' f e+    f e+    Stats.print "E" stats
+ src/E/E.hs view
@@ -0,0 +1,204 @@+module E.E(+    Id(),+    IdMap(),+    IdSet(),+    newIds,+    module E.Type,+    module E.E,+    module E.FreeVars+    ) where++import Data.Char(chr)+import Data.Maybe+import qualified Data.Traversable as T++import C.Prims+import Control.Monad.Identity+import E.FreeVars+import E.Type+import Name.Id+import Name.Name+import Name.Names+import Name.VConsts+import Util.Gen++isWHNF ELit {} = True+isWHNF ELam {} = True+isWHNF EPi {} = True+isWHNF ESort {} = True+isWHNF ELetRec { eBody = e } = isWHNF e+isWHNF _ = False++-----------+-- E values+-----------++instance TypeNames E where+    tInt = ELit (litCons { litName = tInt, litArgs = [], litType = eStar })+    tRational = ELit (litCons { litName = tc_Ratio, litArgs = [tInteger], litType = eStar })+    tChar = ELit (litCons { litName = tChar, litArgs = [], litType = eStar })+    tBool = ELit (litCons { litName = tBool, litArgs = [], litType = eStar })+    tUnit = ELit (litCons { litName = tUnit, litArgs = [], litType = eStar })+    tString =  (ELit (litCons { litName = tc_List, litArgs = [tChar], litType = eStar }))+    tInteger = ELit (litCons { litName = tInteger, litArgs = [], litType = eStar })+    tWorld__ = ELit (litCons { litName = tc_State_, litArgs = [realWorld], litType = eHash }) where+        realWorld = ELit (litCons { litName = tc_RealWorld, litArgs = [], litType = eStar })+    tIntzh = ELit (litCons { litName = tIntzh, litArgs = [], litType = eHash })+    tEnumzh = ELit (litCons { litName = tEnumzh, litArgs = [], litType = eHash })+    tCharzh = ELit (litCons { litName = tCharzh, litArgs = [], litType = eHash, litAliasFor = Just tBits32zh })++tIntegerzh = ELit (litCons { litName = rt_bits_max_, litArgs = [], litType = eHash })+tBits32zh = ELit (litCons { litName = tIntzh, litArgs = [], litType = eHash })++instance ConNames E where+    vTrue = ELit vTrue+    vFalse = ELit vFalse+    vUnit  = ELit vUnit++instance ConNames (Lit E E) where+    vTrue  = (litCons { litName = dc_Boolzh, litArgs = [ELit lTruezh], litType = tBool })+    vFalse = (litCons { litName = dc_Boolzh, litArgs = [ELit lFalsezh], litType = tBool })+    vUnit  = (litCons { litName = dc_Unit, litArgs = [], litType = tUnit })++-- values+tFunc a b = ePi (tVr emptyId a) b+tvrSilly = tVr sillyId Unknown+tBoolzh = ELit litCons { litName = tc_Bool_, litType = eHash, litAliasFor = Just tEnumzh }+lFalsezh = (LitInt 0 tBoolzh)+lTruezh = (LitInt 1 tBoolzh)++-----------------+-- E constructors+-----------------++ePi a b = EPi a b++eLam v (EError s t) = EError s (ePi v t)+eLam v t = ELam v t++-- | throw away first n EPi terms+discardArgs :: Int -> E -> E+discardArgs 0 e = e+discardArgs n (EPi _ b) | n > 0 = discardArgs (n - 1) b+discardArgs _ _ = error "discardArgs"++tvrName :: Monad m => TVr  -> m Name+tvrName (TVr {tvrIdent =  n }) | Just a <- fromId n = return a+tvrName tvr = fail $ "TVr is not Name: " ++ show tvr++tvrShowName :: TVr -> String+tvrShowName t = show (tvrIdent t)++modAbsurd = toModule "Jhc@.Absurd"+modBox    = toModule "Jhc@.Box"++nameConjured :: Module -> E -> Name+nameConjured mod n = toName TypeConstructor (mod,f n "") where+    f (ESort s) = shows s+    f (EPi TVr { tvrType = t1 } t2) = ('^':) . f t1 . f t2+    f _ = error $ "nameConjured: " ++ show (mod,n)++fromConjured :: Monad m => Module -> Name -> m E+fromConjured mod n = maybeM ("fromConjured: " ++ show (mod,n)) $ do+    let f s = funit s `mplus` flam s+        flam ('^':xs) = do (x,rs) <- f xs; (y,gs) <- f rs; return (EPi tvr { tvrType = x } y,gs)+        flam _ = Nothing+        funit ('*':xs) = return (eStar,xs)+        funit ('#':xs) = return (eHash,xs)+        funit ('!':xs) = return (ESort EBang,xs)+        funit ('(':'#':')':xs) = return (ESort ETuple,xs)+        funit _ = Nothing+    (TypeConstructor,(mod',an)) <- return $  fromName n+    guard (mod' == mod)+    (r,"") <- f an+    return r++isBottom EError {} = True+isBottom _ = False++caseBodiesMapM :: Monad m => (E -> m E) -> E -> m E+caseBodiesMapM f ec@ECase { eCaseAlts = as, eCaseDefault = d } = do+    let g (Alt l e) = f e >>= return . Alt l+    as' <- mapM g as+    d' <- T.mapM f d+    return $ caseUpdate ec { eCaseAlts = as', eCaseDefault = d' }+caseBodiesMapM _ _ = error "caseBodiesMapM"++caseBodiesMap :: (E -> E) -> E -> E+caseBodiesMap f ec = runIdentity $ caseBodiesMapM (\x -> return $ f x) ec++eToList :: Monad m => E -> m  [E]+eToList (ELit LitCons { litName = n, litArgs = [e,b] }) | dc_Cons == n = eToList b >>= \x -> return (e:x)+eToList (ELit LitCons { litName = n, litArgs = [] }) | dc_EmptyList == n = return []+eToList _ = fail "eToList: not list"++toString (ELit LitCons { litName = n, litArgs = [], litType = t }) = if dc_EmptyList == n && t == tString then return "" else fail "not a string"+toString x = eToList x >>= mapM fromChar where+    fromChar (ELit LitCons { litName = dc, litArgs = [ELit (LitInt ch t)] }) | dc == dc_Char = return (chr $ fromIntegral ch)+    fromChar _ = fail "fromChar: not char"++ltTuple ts = ELit $ litCons { litName = nameTuple TypeConstructor (length ts), litArgs = ts, litType = eStar }+ltTuple' ts = ELit $ litCons { litName = unboxedNameTuple TypeConstructor (length ts), litArgs = ts, litType = eHash }++p_unsafeCoerce = primPrim "unsafeCoerce"+p_dependingOn = primPrim "dependingOn"+p_toTag = primPrim "toTag"+p_fromTag = primPrim "fromTag"++fromUnboxedTuple :: Monad m => E -> m [E]+fromUnboxedTuple (ELit LitCons { litName = n, litArgs = as }) | Just _ <- fromUnboxedNameTuple n = return as+fromUnboxedTuple _ = fail "fromUnboxedTuple: not a tuple"++isUnboxedTuple m = isJust (fromUnboxedTuple m)++instance Show E where+    showsPrec d (EAp aa ab) = showParen (d >= 10)+	      (showString "EAp" . showChar ' ' . showsPrec 10 aa . showChar ' ' .+	       showsPrec 10 ab)+    showsPrec d (ELam aa ab) = showParen (d >= 10)+	      (showString "ELam" . showChar ' ' . showsPrec 10 aa+	       . showChar ' ' . showsPrec 10 ab)+    showsPrec d (EPi aa ab) | tvrIdent aa == emptyId = showParen (d >= 10)+	      (showsPrec 10 (tvrType aa) . showString " -> " .+	       showsPrec 10 ab)+    showsPrec d (EPi aa ab) = showParen (d >= 10)+	      (showString "EPi" . showChar ' ' . showsPrec 10 aa . showChar ' ' .+	       showsPrec 10 ab)+    showsPrec d (EVar aa) = showParen (d >= 10)+	      (showString "EVar" . showChar ' ' . showsPrec 10 aa)+    showsPrec d (Unknown) = showString "Unknown"+    showsPrec d (ESort aa) = showsPrec d aa+    --showsPrec d (ESort aa) = showParen (d >= 10)+    --          (showString "ESort" . showChar ' ' . showsPrec 10 aa)+    showsPrec d (ELit aa) = showsPrec 10 aa+    --showsPrec d (ELit aa) = showParen (d >= 10)+    --          (showString "ELit" . showChar ' ' . showsPrec 10 aa)+    showsPrec d (ELetRec aa ab) = showParen (d >= 10)+	      (showString "ELetRec" . showChar '{' .+	       showString "eDefs" . showChar '=' . showsPrec 10 aa+	       . showChar ',' .+	       showString "eBody" . showChar '=' . showsPrec 10 ab+	       . showChar '}')+    showsPrec d (EPrim aa ab ac) = showParen (d >= 10)+	      (showString "EPrim" . showChar ' ' . showsPrec 10 aa+	       . showChar ' ' . showsPrec 10 ab . showChar ' ' . showsPrec 10 ac)+    showsPrec d (EError aa ab) = showParen (d >= 10)+	      (showString "EError" . showChar ' ' . showsPrec 10 aa+	       . showChar ' ' . showsPrec 10 ab)+    showsPrec d (ECase aa ab ac ad ae af) = showParen (d >= 10)+	      (showString "ECase" . showChar '{' .+	       showString "eCaseScrutinee" . showChar '=' . showsPrec 10 aa+	       . showChar ',' .+	       showString "eCaseType" . showChar '=' . showsPrec 10 ab+	       . showChar ',' .+	       showString "eCaseBind" . showChar '=' . showsPrec 10 ac+	       . showChar ',' .+	       showString "eCaseAlts" . showChar '=' . showsPrec 10 ad+	       . showChar ',' .+	       showString "eCaseDefault" . showChar '=' . showsPrec 10 ae+	       . showChar ',' .+	       showString "eCaseAllFV" . showChar '=' . showsPrec 10 af+	       . showChar '}')++instance Show e => Show (Alt e) where+    showsPrec n (Alt l e) = showParen (n > 10) $ shows l . showString " -> " . shows e
+ src/E/Eta.hs view
@@ -0,0 +1,213 @@+module E.Eta(+    ArityType(ATop,ABottom),+    etaExpandAp,+    annotateArity,+    deleteArity,+    etaExpandDef,+    etaExpandDef',+    etaExpandProgram,+    getArityInfo,+    etaAnnotateProgram,+    etaReduce+    ) where++import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Writer+import Data.Typeable++import DataConstructors+import E.Annotate+import E.E+import E.Inline+import E.Program+import E.Subst+import E.TypeCheck+import E.Values+import GenUtil hiding(replicateM_)+import Info.Types+import Name.Id+import Support.FreeVars+import Util.NameMonad+import Util.SetLike+import qualified Info.Info as Info+import qualified Stats++data ArityType = AFun Bool ArityType | ABottom | ATop+    deriving(Eq,Ord,Typeable)++instance Show ArityType where+    showsPrec _ ATop = ("ArT" ++)+    showsPrec _ ABottom = ("ArB" ++)+    showsPrec _ (AFun False r) = ('\\':) . shows r+    showsPrec _ (AFun True r) = ("\\o" ++) . shows r++arity at = f at 0 where+    f (AFun _ a) n = f a $! (1 + n)+    f x n | n `seq` x `seq` True = (x,n)+    f _ _ = error "Eta.arity: bad."++getArityInfo tvr+    | Just at <- Info.lookup (tvrInfo tvr) = arity at+    | otherwise = (ATop,0)++isOneShot x = getProperty prop_ONESHOT x++arityType :: E -> ArityType+arityType e = f e where+    f EError {} = ABottom+    f (ELam x e) = AFun (isOneShot x) (f e)+    f (EAp a b) = case f a of+        AFun _ xs | isCheap b -> xs+        _ -> ATop+    f ec@ECase { eCaseScrutinee = scrut } = case foldr1 andArityType (map f $ caseBodies ec) of+        xs@(AFun True _) -> xs+        xs | isCheap scrut -> xs+        _ -> ATop+    f (ELetRec ds e) = case f e of+        xs@(AFun True _) -> xs+        xs | all isCheap (snds ds) -> xs+        _ -> ATop+    f (EVar tvr) | Just at <- Info.lookup (tvrInfo tvr) = at+    f _ = ATop++andArityType ABottom	    at2		  = at2+andArityType ATop	    at2		  = ATop+andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)+andArityType at1	    at2		  = andArityType at2 at1++annotateArity e nfo = annotateArity' (arityType e) nfo++annotateArity' at nfo = Info.insert (Arity n (b == ABottom)) $ Info.insert at nfo where+    (b,n) = arity at++-- delety any arity information+deleteArity nfo = Info.delete  (undefined :: Arity) $ Info.delete (undefined :: Arity) nfo++expandPis :: DataTable -> E -> E+expandPis dataTable e = f (followAliases dataTable e) where+    f (EPi v r) = EPi v (f (followAliases dataTable r))+    f e = e++{-+fromPi' :: DataTable ->  E -> (E,[TVr])+fromPi' dataTable e = f [] (followAliases dataTable e) where+    f as (EPi v e) = f (v:as) (followAliases dataTable e)+    f as e  =  (e,reverse as)+-}++-- this annotates, but only expands top-level definitions+etaExpandProgram :: Stats.MonadStats m => Program -> m Program+--etaExpandProgram prog = runNameMT (programMapDs f (etaAnnotateProgram prog)) where+etaExpandProgram prog = runNameMT (programMapDs f prog) where+    f (t,e) = do etaExpandDef' (progDataTable prog) 0 t e++-- this annotates a program with its arity information, iterating until a fixpoint is reached.+etaAnnotateProgram :: Program -> Program+etaAnnotateProgram prog = runIdentity $ programMapRecGroups mempty pass iletann pass f prog where+    pass _ = return+    iletann e nfo = return $ annotateArity e nfo+    letann e nfo = case Info.lookup nfo of+        Nothing -> put True >> return (annotateArity e nfo)+        Just at -> do+            let at' = arityType e+            when (at /= at') (put True)+            return $ annotateArity' at' nfo+    f (rg,ts) = do+        let (ts',fs) = runState (annotateCombs mempty pass letann pass ts) False+        if fs then f (rg,ts') else return ts'++-- | eta reduce as much as possible+etaReduce :: E -> E+etaReduce e = f e where+        f (ELam t (EAp x (EVar t'))) | t == t' && (tvrIdent t `notMember` (freeVars x :: IdSet)) = f x+        f e = e++-- | only reduce if all lambdas can be discarded. otherwise leave them in place+{-+etaReduce' :: E -> (E,Int)+etaReduce' e = case f e 0 of+        (ELam {},_) -> (e,0)+        x -> x+    where+        f (ELam t (EAp x (EVar t'))) n | n `seq` True, t == t' && (tvrIdent t `notMember` (freeVars x :: IdSet)) = f x (n + 1)+        f e n = (e,n)+-}++etaExpandDef' dataTable n t e = etaExpandDef dataTable n t e >>= \x -> case x of+    Nothing -> return (tvrInfo_u (annotateArity e) t,e)+    Just x -> return x++--collectIds :: E -> IdSet+--collectIds e = execWriter $ annotate mempty (\id nfo -> tell (singleton id) >> return nfo) (\_ -> return) (\_ -> return) e+-- | eta expand a definition+etaExpandDef :: (NameMonad Id m,Stats.MonadStats m)+    => DataTable+    -> Int        -- ^ eta expand at least this far, independent of calculated amount+    -> TVr+    -> E+    -> m (Maybe (TVr,E))+etaExpandDef _ _ _ e | isAtomic e = return Nothing -- will be inlined+etaExpandDef dataTable min t e  = ans where+    --fvs = foldr insert (freeVars (b,map getType rs,(tvrType t,e))) (map tvrIdent rs) `mappend` collectIds e+    --(b,rs) = fromLam e+    at = arityType e+    zeroName = case fromAp e of+        (EVar v,_) -> "use.{" ++ tvrShowName v+        _ -> "random"+    --nameSupply = [ n |  n <- [2,4 :: Int ..], n `notMember` fvs  ]+    nameSupply = undefined+    ans = do+        -- note that we can't use the type in the tvr, because it will not have the right free typevars.+        (ne,flag) <- f min at e (expandPis dataTable $ infertype dataTable e) nameSupply+        if flag then return (Just (tvrInfo_u (annotateArity' at) t,ne)) else return Nothing+    f min (AFun _ a) (ELam tvr e) (EPi tvr' rt) _ns = do+        (ne,flag) <- f (min - 1) a e (subst tvr' (EVar tvr) rt) _ns+        return (ELam tvr ne,flag)+    f min (AFun _ a) e (EPi tt rt) _nns = do+        if tvrIdent t == emptyId+         then Stats.mtick ("EtaExpand." ++ zeroName)+          else Stats.mtick ("EtaExpand.def.{" ++ tvrShowName t)+        n <- newName+        let nv = tt { tvrIdent = n }+            eb = EAp e (EVar nv)+        (ne,_) <- f (min - 1) a eb (subst tt (EVar nv) rt) _nns+        return (ELam nv ne,True)+    f min a e (EPi tt rt) _nns | min > 0 = do+        if tvrIdent t == emptyId+         then Stats.mtick ("EtaExpand.min." ++ zeroName)+          else Stats.mtick ("EtaExpand.min.def.{" ++ tvrShowName t)+        n <- newName+        let nv = tt { tvrIdent = n }+            eb = EAp e (EVar nv)+        (ne,_) <- f (min - 1) a eb (subst tt (EVar nv) rt) _nns+        return (ELam nv ne,True)+    f _ _ e _ _ = do+        return (e,False)++-- | eta expand a use of a value+etaExpandAp :: (NameMonad Id m,Stats.MonadStats m) => DataTable -> TVr -> [E] -> m (Maybe E)+etaExpandAp dataTable tvr xs = do+    r <- etaExpandDef dataTable 0 tvr { tvrIdent = emptyId} (foldl EAp (EVar tvr) xs)+    return (fmap snd r)++{-+etaExpandAp _ _ [] = return Nothing  -- so simple renames don't get eta-expanded+etaExpandAp dataTable t as | Just (Arity n err) <- Info.lookup (tvrInfo t) = case () of+    () | n > length as -> do+            let e = foldl EAp (EVar t) as+            let (_,ts) = fromPi' dataTable (infertype dataTable e)+                ets = (take (n - length as) ts)+            mticks (length ets) ("EtaExpand.use.{" ++ tvrShowName t)+            let tvrs = f mempty [ (tvrIdent t,t { tvrIdent = n }) |  n <- [2,4 :: Int ..], not $ n `Set.member` freeVars (e,ets) | t <- ets ]+                f map ((n,t):rs) = t { tvrType = substMap map (tvrType t)} : f (Map.insert n (EVar t) map) rs+                f _ [] = []+            return (Just $ foldr ELam (foldl EAp e (map EVar tvrs)) tvrs)+       | err && length as > n -> do+            let ot = infertype dataTable (foldl EAp (EVar t) as)+            mticks (length as - n) ("EtaExpand.bottoming.{" ++ tvrShowName t)+            return $ Just (prim_unsafeCoerce ot (foldl EAp (EVar t) (take n as)))  -- we can drop any extra arguments applied to something that bottoms out.+       | otherwise -> return Nothing++etaExpandAp _ t as = return Nothing+-}
+ src/E/Eval.hs view
@@ -0,0 +1,108 @@+module E.Eval(eval, strong) where++-- Simple lambda Calculus interpreter+-- does not handle recursive Let or Case statements, but those don't appear in types anyway.++import Data.Monoid+import qualified Data.Map as Map++--import Debug.Trace+import Doc.DocLike+import Doc.PPrint+import E.E+import E.Subst+import Name.Id+import {-# SOURCE #-} E.Show++trace _ x = x++-- evaluate to WHNF+eval :: E -> E+eval term = eval' term []  where+    -- final terms+    eval' t@EVar {} [] = t+    eval' (ELam v body) [] = check_eta $ ELam v (eval body)+    eval' (EPi v body) [] = check_eta $ EPi v (eval body)+    eval' e@Unknown [] = e+    eval' e@ESort {} [] = e+    eval' (ELit lc@LitCons { litArgs = es }) [] = ELit lc { litArgs = map eval es }+    eval' e@ELit {} [] = e++    -- argument applications+    eval' (ELit lc@LitCons { litArgs = es, litType = EPi tb tt }) (t:rest) = eval' (ELit lc { litArgs = es ++ [t], litType = subst tb t tt }) rest+    eval' (ELit LitCons { litArgs = es, litAliasFor = Just af }) (t:rest) = eval' af (es ++ t:rest)++    eval' (ELam v body) (t:rest) = eval' (subst v t body) rest+    eval' (EPi v body) (t:rest) = eval' (subst v t body) rest   -- fudge+    eval' (EAp t1 t2) stack = eval' t1 (t2:stack)+    eval' t@EVar {} stack = unwind t stack+    eval' ELetRec { eDefs = ds, eBody = e } stack = eval' (f (decomposeDs ds) e) stack where+        f [] e = e+        f (Left (x,y):ds) e =  subst x y (f ds e)+        f (Right _:_) _ = error $ "cannot eval recursive let"+    eval' e@(ELit LitCons {}) stack = unwind e stack+    eval' e _ = error $ "Cannot eval: " ++ show e++    unwind t [] = t+    unwind t (t1:rest) = unwind (EAp t $ eval t1) rest++    -- currently we do not do eta check. etas should only appear for good reason.+    check_eta x = x++strong :: Monad m => [(TVr,E)] -> E -> m E+strong dsMap' term = trace ("strong: " ++ show term) $ eval' dsMap term [] where+    dsMap = Map.fromList dsMap'+    etvr ds tvr = do+        t' <- (eval' ds (tvrType tvr) [])+        return $ tvr { tvrType = t' }++    eval' :: Monad m => Map.Map TVr E -> E -> [E] -> m E+    eval' ds (ELam v body) [] = do+        let ds' = Map.delete v ds+        v' <- etvr ds' v+        body' <- (eval' ds' body [])+        check_eta $ ELam v' body'+    eval' ds (EPi v body) [] = do+        let ds' = Map.delete v ds+        body' <- (eval' ds' body [])+        v' <- etvr ds' v+        check_eta $ EPi v' body'+    eval' ds e@Unknown [] = return e+    eval' ds e@ESort {} [] = return e+    eval' ds (ELit lc@LitCons { litArgs = es, litType = t }) [] = do+        es' <- mapM (\e -> eval' ds e []) es+        t' <-  (eval' ds t [])+        return $ ELit $ lc { litArgs = es', litType = t' }+    eval' ds e@ELit {} [] = return e+    eval' ds (ELit lc@LitCons { litArgs = es, litType = EPi tb tt }) (t:rest) = eval' ds (ELit lc { litArgs = es ++ [t], litType = subst tb t tt }) rest+    eval' ds (ELit LitCons { litArgs = es, litAliasFor = Just af }) (t:rest) = eval' ds af (es ++ t:rest)+    eval' ds (ELam v body) (t:rest) = eval' ds (subst v t body) rest+    eval' ds (EPi v body) (t:rest) = eval' ds (subst v t body) rest   -- fudge+    eval' ds (EAp t1 t2) stack = eval' ds t1 (t2:stack)+    eval' _ds (EVar TVr { tvrIdent = eid }) _stack | eid == emptyId = fail "empty ident in term"+    eval' ds t@(EVar v) stack+        | Just x <- Map.lookup v ds = trace ("strong-lookup: " ++ show v) $ eval' ds x stack+        | otherwise = do+            tvr <- etvr ds v+            unwind ds (EVar tvr) stack+    eval' ds ELetRec { eDefs = ds', eBody = e } stack = eval' (Map.fromList ds'  `mappend` ds) e  stack+    eval' ds e@(ELit LitCons {}) stack = unwind ds e stack+    eval' ds (EError s ty) (t:rest) = do+        nt <- eval' ds (EAp ty t) rest+        return (EError s nt)+    eval' ds e@EError {} [] = do return e++    eval' ds e stack= fail . render $ text "Cannot strong:"+                                      <$> pprint e+                                      <$> text "With stack:"+                                      <$> pprint stack+                                      <$> text "And bindings for:"+                                      <$> pprint ds++    unwind ds t [] = return t+    unwind ds t (t1:rest) = do+        e <-  eval' ds t1 []+        unwind ds (EAp t $ e) rest++    -- currently we do not do eta check. etas should only appear for good reason.+    check_eta x = return x
+ src/E/FreeVars.hs view
@@ -0,0 +1,136 @@+module E.FreeVars(+    decomposeLet,+    decomposeDs,+    caseUpdate,+    freeIds+    ) where++import Data.Monoid++import E.Type+import GenUtil+import Name.Id+import Support.FreeVars+import Util.Graph+import Util.SetLike as S++-------------------------+-- finding free variables+-------------------------++getLitTyp (LitInt _ t) = t+getLitTyp LitCons { litType = t } = t++instance FreeVars E [TVr] where+    freeVars x = values $ (freeVars x :: IdMap TVr)+instance FreeVars E [Id] where+    freeVars e =  idSetToList (freeVars e)++instance FreeVars E t => FreeVars TVr t where+    freeVars tvr = freeVars (tvrType tvr :: E)++instance (FreeVars E x) => FreeVars (Lit TVr E) x where+    freeVars l =  mconcat $ freeVars (getLitTyp l :: E ):(map (freeVars . (tvrType :: TVr -> E) ) $ litBinds l)++instance FreeVars (Alt E) IdSet where+    freeVars as@(Alt l e) = mconcat $ freeVars (getLitTyp l):(freeVars e S.\\ fromList [ tvrIdent t | t <- litBinds l]):(map (freeVars . tvrType) $ litBinds l)+instance FreeVars E IdSet where+    freeVars e = freeIds e++instance FreeVars (Alt E) (IdMap TVr) where+    freeVars as@(Alt l e) = mconcat $ freeVars (getLitTyp l):(freeVars e S.\\ fromList [ (tvrIdent t,t) | t <- litBinds l]):(map (freeVars . tvrType) $ litBinds l)+instance FreeVars E (IdMap TVr) where+    freeVars e = freeIdMap e+instance FreeVars E (IdMap (Maybe E)) where+    freeVars e = fmap (const Nothing) $ freeIdMap e++-- | separate out recursive strongly connected components from a declaration list++decomposeDs :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]+decomposeDs bs = scc g where+    g = newGraph bs (tvrIdent . fst ) (toList . uncurry bindingFreeVars)++-- | pull apart an ELet and separate out recursive strongly connected components from an ELet.+decomposeLet :: E ->  ([Either (TVr, E) [(TVr,E)]],E)+decomposeLet ELetRec { eDefs = ds, eBody = e } = (decomposeDs ds,e)+decomposeLet e = ([],e)++caseUpdate :: E -> E+caseUpdate ec@ECase {} = ec { eCaseAllFV = fv ec } where+    fv ~(ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d, eCaseType = ty }) = mconcat (freeIds e:freeIds (tvrType  b):freeIds ty:(delete (tvrIdent b) $ mconcat (freeVars d:map freeVars as)  ):[])+caseUpdate e = e++-- we export this to get a concrete type for free id sets.+freeIds ::  E -> IdSet+freeIds =   fv where+    (<>) = mappend+    fv (EAp e1 e2) = fv e1 <> fv e2+    fv (EVar tvr@TVr { tvrIdent = i }) = singleton i <> freeVarsInfo (tvrInfo tvr)+    fv (ELam TVr { tvrIdent = i, tvrType = t} e) = delete i $ fv e <> fv t+    fv (EPi  TVr { tvrIdent = i, tvrType = t} e) = delete i $ fv e <> fv t+    fv ELetRec { eDefs = dl, eBody = e } =  ((tl <> bl <> fv e) S.\\ fromList ll)  where+        (ll,tl,bl) = liftT3 (id,mconcat,mconcat) $ unzip3 $+            map (\(tvr@(TVr { tvrIdent = j }),y) -> (j, freeVars tvr, fv y)) dl+    fv (EError _ e) = fv e+    fv (ELit l) = fvLit l+    fv (EPrim _ es e) = mconcat $ fv e : map fv es+    --fv ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d, eCaseType = ty } = mconcat ( fv e:freeVars (tvrType  b):freeVars ty:(delete (tvrIdent b) $ mconcat (freeVars d:map freeVars as)  ):[])+    fv ECase { eCaseAllFV = cfv } = cfv+    fv Unknown = mempty+    fv ESort {} = mempty+    fvLit LitCons { litArgs = es, litType = e } = mconcat $ fv e:map fv es+    fvLit l = fv (getLitTyp l)++-- we export this to get a concrete type for free id sets.+freeIdMap ::  E -> IdMap TVr+freeIdMap =   fv where+    (<>) = mappend+    fv (EAp e1 e2) = fv e1 <> fv e2+    fv (EVar tvr@TVr { tvrIdent = i }) = msingleton i tvr+    fv (ELam TVr { tvrIdent = i, tvrType = t} e) = delete i $ fv e <> fv t+    fv (EPi  TVr { tvrIdent = i, tvrType = t} e) = delete i $ fv e <> fv t+    fv ELetRec { eDefs = dl, eBody = e } =  ((tl <> bl <> fv e) S.\\ fromList ll)  where+        (ll,tl,bl) = liftT3 (id,mconcat,mconcat) $ unzip3 $+            map (\(tvr@(TVr { tvrIdent = j, tvrType =  t}),y) -> ((j,tvr), fv t, fv y)) dl+    fv (EError _ e) = fv e+    fv (ELit l) = fvLit l+    fv (EPrim _ es e) = mconcat $ fv e : map fv es+    fv ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d, eCaseType = ty } = mconcat ( fv e:freeVars (tvrType  b):freeVars ty:(delete (tvrIdent b) $ mconcat (freeVars d:map freeVars as)  ):[])+    fv Unknown = mempty+    fv ESort {} = mempty+    fvLit LitCons { litArgs = es, litType = e } = mconcat $ fv e:map fv es+    fvLit l = fv (getLitTyp l)++-- | determine free variables of a binding site+instance FreeVars TVr IdSet where+    freeVars t = freeVars (tvrType t) `mappend` freeVarsInfo (tvrInfo t)++-- | this determines all free variables of a definition taking rules into account+bindingFreeVars :: TVr -> E -> IdSet+bindingFreeVars t e = freeVars t `mappend` freeVars e++freeVarsInfo nfo = mempty+--instance FreeVars TVr (IdMap TVr) where+--    freeVars t = freeVars (tvrType t) `mappend` freeVars (Info.fetch (tvrInfo t) :: ARules)++instance FreeVars ARules IdSet where+    freeVars a = aruleFreeVars a++-- note, we include references to this combinator in its free variables.+instance FreeVars Comb IdSet where+    freeVars a = freeVars (tvrType $ combHead a) `union` freeVars (combBody a) `union` (freeVars $ combRules a)++instance FreeVars Comb [Id] where+    freeVars a = toList $ (freeVars a :: IdSet)++-- | we delete the free variables of the heads of a rule from the rule's free+-- variables. the reason for doing this is that the rule cannot fire if all its+-- heads are in scope, and if it were not done then many functions seem+-- recursive when they arn't actually.++instance FreeVars Rule IdSet where+    freeVars rule = freeVars (ruleBody rule) S.\\ (fromList (map tvrIdent $ ruleBinds rule) `mappend` ruleHeadFV rule)+--instance FreeVars Rule (IdMap TVr) where+--    freeVars rule = freeVars (ruleBody rule) S.\\ fromList [ (tvrIdent t,t) | t <- ruleBinds rule]++ruleHeadFV r = (S.insert (tvrIdent $ ruleHead r) $ freeVars (ruleArgs r)) S.\\ fromList (map tvrIdent $ ruleBinds r)
+ src/E/FromHs.hs view
@@ -0,0 +1,1033 @@+module E.FromHs(+    convertDecls,+    convertRules,+    createInstanceRules,+    procAllSpecs,+    getMainFunction+    ) where++import Data.Char+import Control.Monad.Error+import Control.Monad.Identity+import Control.Monad.RWS+import Data.List(isPrefixOf,nub)+import Prelude+import Text.Printf+import qualified Data.Map as Map+import qualified Data.Traversable as T+import qualified Text.PrettyPrint.HughesPJ as PPrint++import C.FFI+import C.Prims as CP+import DataConstructors+import Doc.DocLike+import Doc.PPrint+import E.E+import E.Eta+import E.Eval(eval)+import E.LetFloat(atomizeAp)+import E.PrimDecode+import E.Rules+import E.Show(render)+import E.Subst+import E.Traverse+import E.TypeCheck+import E.Values+import FrontEnd.Class+import FrontEnd.HsSyn as HS+import FrontEnd.Rename(unRename)+import FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse(getNamesFromHsPat)+import FrontEnd.Tc.Main(isTypePlaceholder)+import FrontEnd.Tc.Module(TiData(..))+import FrontEnd.Tc.Type hiding(Rule(..))+import FrontEnd.Warning+import Info.Types+import Name.Id+import Name.Name as Name+import Name.Names+import Name.VConsts+import Options+import PackedString+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Gen+import Util.NameMonad+import Util.SetLike+import qualified FlagOpts as FO+import qualified FrontEnd.Tc.Type as T(Rule(..))+import qualified FrontEnd.Tc.Type as Type+import qualified Info.Info as Info++ump sl e = EError (show sl ++ ": Unmatched pattern") e++r_bits32       = ELit litCons { litName = rt_bits32, litType = eHash }+r_bits_max_    = ELit litCons { litName = rt_bits_max_, litType = eHash }+r_bits_ptr_    = ELit litCons { litName = rt_bits_ptr_, litType = eHash }++createIf e a b = do+    [tv] <- newVars [Unknown]+    return $ createIfv tv e a b++createIfv v e a b = res where+    tv = v { tvrType = tBoolzh }+    ic = eCase (EVar tv) [Alt lTruezh a, Alt lFalsezh b] Unknown+    res = eCase e [Alt (litCons { litName = dc_Boolzh, litArgs = [tv], litType = tBool }) ic] Unknown++ifzh e a b = eCase e [Alt lTruezh a, Alt lFalsezh b] Unknown++newVars :: UniqueProducer m => [E] -> m [TVr]+newVars xs = f xs [] where+    f [] xs = return $ reverse xs+    f (x:xs) ys = do+        s <- newUniq+        f xs (tVr (anonymous s) x:ys)++tipe t = f t where+    f (TAp (TAp (TCon arr) a1) a2) | tyconName arr == tc_Arrow = f (TArrow a1 a2)+    f (TAp t1 t2) = eAp (f t1) (f t2)+    f (TArrow t1 t2) =  EPi (tVr emptyId (f t1)) (f t2)+    f (TCon (Tycon n k)) | Just n' <- Map.lookup n primitiveAliases = ELit litCons { litName = n', litType = kind k }+    f (TCon (Tycon n k)) =  ELit litCons { litName = n, litType = kind k }+    f (TVar tv) = EVar (cvar [] tv)+    f (TMetaVar mv) = cmvar mv+    f (TForAll vs (ps :=> t)) = foldr EPi (f t) (map (cvar $ freeVars ps) vs)+    f (TExists xs (_ :=> t)) = let+        xs' = map (kind . tyvarKind) xs+        in ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = f t:xs', litType = eHash }+    f TAssoc {} = error "E.FromHs.tipe TAssoc"+    cvar fvs tv@Tyvar { tyvarName = n, tyvarKind = k }+        | tv `elem` fvs = setProperty prop_SCRUTINIZED (tVr (lt n) (kind k))+        | otherwise = tVr (lt n) (kind k)+    cmvar MetaVar { metaKind = k } = tAbsurd (kind k)+    lt n | nameType n == TypeVal = toId n  -- verifies namespace+         | otherwise = error "E.FromHs.lt"++kind (KBase KUTuple) = eHash+kind (KBase KHash) = eHash+kind (KBase Star) = eStar+kind (KBase KQuest) = eStar      -- XXX why do these still exist?+kind (KBase KQuestQuest) = eStar+kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2)+kind (KVar _) = error "Kind variable still existing."+kind _ = error "E.FromHs.kind: unknown"++fromTyvar (Tyvar n k) = tVr (toId n) (kind k)++fromSigma (TForAll vs (_ :=> t)) = (map fromTyvar vs, tipe t)+fromSigma t = ([], tipe t)++monadicLookup' k m = case Map.lookup k m of+    Just x  -> return x+    Nothing -> fail $ "key not found: " ++ show k++convertValue n = do+    assumps <- asks ceAssumps+    dataTable <- asks ceDataTable+    t <- monadicLookup' n assumps+    let ty = removeNewtypes dataTable (tipe t)+    cc <- asks ceCoerce+    lm <- case Map.lookup n cc of+        Nothing -> do+            let (vs,_) = fromSigma t+            return (flip (foldr eLam) vs)+        Just CTId -> do return id+        Just ~(CTAbs ts) -> do return $ \e -> foldr eLam e (map fromTyvar ts)+    return (tVr (toId n) ty,ty,lm)++--convertType t = do+--    dataTable <- asks ceDataTable+--    return $ removeNewtypes dataTable (tipe t)++matchesConv ms = map v ms where+    v (HsMatch _ _ ps rhs wh) = (ps,rhs,wh)++altConv as = map v as where+    v (HsAlt _ p rhs wh) = ([p],rhs,wh)++argTypes e = span (sortSortLike . getType) (map tvrType xs) where+    (_,xs) = fromPi e+argTypes' :: E -> ([E],E)+argTypes' e = let (x,y) = fromPi e in (map tvrType y,x)++getMainFunction :: Monad m => DataTable -> Name -> (Map.Map Name (TVr,E)) -> m (TVr,E)+getMainFunction dataTable name ds = do+  mt <- case Map.lookup name ds of+    Just x -> return x+    Nothing -> fail $ "Could not find main function: " ++ show name+  let funcs = runIdentity $ T.mapM (\n -> return . EVar . fst $ runEither (show n) $ monadicLookup' n ds) sFuncNames+  nameToEntryPoint dataTable (fst mt) (toName Name.Val "theMain") Nothing funcs++nameToEntryPoint :: Monad m => DataTable -> TVr -> Name -> Maybe FfiExport -> FuncNames E -> m (TVr,E)+nameToEntryPoint dataTable main cname ffi ds = ans where+    ans = do+        let runMain      = func_runMain ds+            runExpr      = func_runExpr ds+            runNoWrapper = func_runNoWrapper ds+            runRaw       = func_runRaw ds+        let e = case extractIO (getType maine) of+                Just x | not (fopts FO.Wrapper) -> EAp (EAp runNoWrapper x) maine+                Just x ->  EAp (EAp runMain  x ) maine+                Nothing | fopts FO.Raw -> EAp (EAp runRaw ty) maine+                Nothing ->  EAp (EAp runExpr ty) maine+            ne = ELam worldVar (EAp e (EVar worldVar))+            worldVar = tvr { tvrIdent = va1, tvrType = tWorld__ }+            theMainTvr =  tVr (toId cname) (infertype dataTable ne)+            tvm@(TVr { tvrType =  ty}) =  main+            maine = foldl EAp (EVar tvm) [ tAbsurd k |  TVr { tvrType = k } <- xs, sortKindLike k ]+            (_,xs) = fromPi ty+        return (tvrInfo_u (case ffi of Just ffi -> Info.insert ffi; Nothing -> id) $ setProperty prop_EXPORTED theMainTvr,ne)++-- | create a RULE for each instance attached to the class methods.+-- These rules allow early specialization of monomorphic code, and are+-- eventually used in E.TypeAnalysis.expandPlaceholder to fill out+-- the generic class method bodies.++{-# NOINLINE createInstanceRules #-}+createInstanceRules :: Monad m => DataTable -> ClassHierarchy -> [(TVr,E)] -> m Rules+createInstanceRules dataTable classHierarchy funcs = return $ fromRules ans where+    ans = concatMap cClass (classRecords classHierarchy)+    cClass classRecord = concat [ method classRecord n mve |+        (n,TForAll _ (_ :=> t)) <- classAssumps classRecord, mve <- findName n ]+    method classRecord methodName (methodVar,_) = as where+        ty = tvrType methodVar+        defaultName = defaultInstanceName methodName+        as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (findClassInsts classHierarchy (className classRecord)) ]+        rule t = makeRule ("Rule.{" ++ show name ++ "}") (toModule (show name),0)+                RuleSpecialization ruleFvs methodVar (vp:map EVar args) (removeNewtypes dataTable body) where+            ruleFvs = [ t | ~(EVar t) <- vs] ++ args+            (vp,vs) = valToPat' (removeNewtypes dataTable $ tipe t)+            name = instanceName methodName (getTypeCons t)+            bodyt = foldl eAp ty (vp:map EVar args)+            body = case findName name of+                Just (n,_) -> runIdentity $ do actuallySpecializeE (EVar n) bodyt+                Nothing -> case findName defaultName of+                    Just (deftvr,_) | otherwise -> runIdentity $ do actuallySpecializeE (EVar deftvr) bodyt+                    Nothing -> EError ( show methodName ++ ": undefined at type " ++  PPrint.render (pprint t)) bodyt+                    --Just (deftvr,_) -> eLet tv vp $ runIdentity $ do actuallySpecializeE (EVar deftvr) (foldl eAp ty $ EVar tv:map EVar args) where -- foldl EAp (EAp (EVar deftvr) (EVar tv)) (map EVar args) where+                    --    tv = tvr { tvrIdent = head [ n | n <- newIds (freeVars vp `mappend` fromList (map tvrIdent args))], tvrType = getType vp }+                    --Just (deftvr,_) | null vs -> foldl EAp (EAp (EVar deftvr) vp) (map EVar args)++        -- this assumes the class argument is always the first type parameter+        (_,_:args') = fromPi ty+        (args,_) = span (sortKindLike . tvrType)  args'++        someIds = newIds (fromList $ map tvrIdent args')+        valToPat' (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = ans where+            ans = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts')+            ts' = [ EVar (tVr j (getType z)) | z <- ts | j <- someIds]+        valToPat' (EPi tv@TVr { tvrType =  a} b)  = (EPi tvr { tvrType =  a'} b',[a',b']) where+            a' = EVar (tVr ja (getType a))+            b' = EVar (tVr jb (getType b))+            (ja:jb:_) = someIds+        valToPat' x = error $ "FromHs.valToPat': " ++ show x++    funcsMap = Map.fromList [ (n,(v,e)) | (v,e) <- funcs, let Just n = fromId (tvrIdent v) ]+    findName name = case Map.lookup name funcsMap of+        Nothing -> fail $ "Cannot find: " ++ show name+        Just n -> return n++getTypeCons (TCon (Tycon n _)) = n+getTypeCons (TAp a _) = getTypeCons a+getTypeCons (TArrow {}) = tc_Arrow+getTypeCons x = error $ "getTypeCons: " ++ show x++unbox :: DataTable -> E -> Id -> (E -> E) -> E+unbox dataTable e _vn wtd | getType (getType e) == eHash = wtd e+unbox dataTable e vn wtd = eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd (EVar tvra))] Unknown where+    te = getType e+    tvra = tVr vn sta+    Just (ExtTypeBoxed cna sta _) = lookupExtTypeInfo dataTable te++createFunc :: [E] -> ([TVr] -> C (E -> E,E)) -> C E+createFunc es ee = do+    dataTable <- getDataTable+    xs <- flip mapM es $ \te -> do+        eti <- ffiTypeInfo ExtTypeVoid te return+        [n] <- newVars [te]+        case eti of+            ExtTypeVoid -> fail "createFunc: attempt to pass a void argument"+            ExtTypeBoxed cn sta _ -> do+                [n'] <- newVars [sta]+                return (n,n',Just cn)+            ExtTypeRaw _ -> do+                return (n,n,Nothing)+    let tvrs' = [ n' | (_,n',_) <- xs ]+        tvrs = [ t | (t,_,_) <- xs]+    (me,innerE) <- ee tvrs'+    let eee = me $ foldr esr innerE xs+        esr (tvr,tvr',Just cn) e = eCase (EVar tvr) [Alt (litCons { litName = cn, litArgs = [tvr'], litType = tvrType tvr }) e] Unknown+        esr (_,_,Nothing) e = e+    return $ foldr ELam eee tvrs++instance GenName String where+   genNames i = map (('x':) . show) [i..]++{-# NOINLINE convertRules #-}+convertRules :: Module -> TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> IO Rules+convertRules mod tiData classHierarchy assumps dataTable hsDecls = ans where+    ans = do+        rawRules <- concatMapM g hsDecls+        return $ fromRules [ makeRule n (mod,i) (if catalyst then RuleCatalyst else RuleUser) vs head args e2 | (catalyst,n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 | i <- [1..] ]+    g (HsPragmaRules rs) = mapM f rs+    g _ = return []+    f pr = do+        let ce = convertE tiData classHierarchy assumps dataTable (hsRuleSrcLoc pr)+        e1 <- ce (hsRuleLeftExpr pr)+        e2 <- ce (hsRuleRightExpr pr)+        (ts,cs) <- runNameMT $ do+            ts <- flip mapM (filter (sortKindLike . getType) $ freeVars e1) $ \tvr -> do+                --return (tvrIdent tvr,tvr)+                nn <- newNameFrom (map (:'\'':[]) ['a' ..])+                return (tvrIdent tvr,tvr { tvrIdent = toId (toName TypeVal nn) })+            cs <- flip mapM [toTVr assumps dataTable (toName Val v) | (v,_) <- hsRuleFreeVars pr ] $ \tvr -> do+                let ur = show $ unRename (toUnqualified $ runIdentity $ fromId (tvrIdent tvr))+                nn <- newNameFrom (ur:map (\v -> ur ++ show v) [1 ::Int ..])+                return (tvrIdent tvr,tvr { tvrIdent = toId (toName Val nn) })+            return (ts,cs)+        let smt = substMap $ fromList [ (x,EVar y)| (x,y) <- ts ]+            sma = substMap $ fromList [ (x,EVar y)| (x,y) <- cs' ]+            cs' =  [ (x,(tvrType_u smt y))| (x,y) <- cs ]+            e2' = deNewtype dataTable $ smt $ sma e2+        --e2 <- atomizeAp False dataTable Stats.theStats mainModule e2'+        let e2 = atomizeAp mempty False dataTable e2'+        return (hsRuleIsMeta pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)++convertE :: TiData -> ClassHierarchy -> Map.Map Name Type+    -> DataTable -> SrcLoc -> HsExp -> IO E+convertE tiData classHierarchy assumps dataTable srcLoc exp = do+    [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable+        [HsPatBind srcLoc (HsPVar v_silly) (HsUnGuardedRhs exp) []]+    return e++v_silly = toName Val ("Jhc@","silly")++data CeEnv = CeEnv {+    ceAssumps :: Map.Map Name Type,+    ceCoerce :: Map.Map Name CoerceTerm,+    ceFuncs  :: FuncNames E,+    ceProps  :: IdMap Properties,+    ceSrcLoc :: SrcLoc,+    ceDataTable :: DataTable+    }++newtype C a = Ce (RWST CeEnv [Warning] Int IO a)+    deriving(Monad,Functor,MonadIO,MonadReader CeEnv,MonadState Int,MonadError IOError)++instance MonadWarn C where+    addWarning w = liftIO (addWarning w)++instance MonadSrcLoc C where+    getSrcLoc = asks ceSrcLoc++instance MonadSetSrcLoc C where+    withSrcLoc sl = local (\ce -> ce { ceSrcLoc = sl })++instance UniqueProducer C where+    newUniq = do+        i <- get+        put $! (i + 1)+        return i++instance DataTableMonad C where+    getDataTable = asks ceDataTable++applyCoersion :: CoerceTerm -> E -> C E+applyCoersion CTId e = return e+applyCoersion ct e = etaReduce `liftM` f ct e where+    f CTId e = return e+    f (CTAp ts) e = return $ foldl eAp e (map tipe ts)+    f (CTAbs ts) e = return $ foldr eLam e (map fromTyvar ts)+    f (CTCompose ct1 ct2) e = f ct1 =<< (f ct2 e)+    f (CTFun CTId) e = return e+    f (CTFun ct) e = do+        let EPi TVr { tvrType = ty } _ = getType e+        [y] <- newVars [ty]+        fgy <- f ct (EAp e (EVar y))+        return (eLam y fgy)++fromTuple_ :: Monad m => E -> m [E]+fromTuple_ (ELit LitCons { litName = n, litArgs = as }) | Just c <- fromUnboxedNameTuple n, c == length as = return as+fromTuple_ e = fail "fromTuple_ : not unboxed tuple"++{-# NOINLINE convertDecls #-}+convertDecls :: TiData -> IdMap Properties+    -> ClassHierarchy -> Map.Map Name Type -> DataTable+    -> [HsDecl] -> IO [(Name,TVr,E)]+convertDecls tiData props classHierarchy assumps dataTable hsDecls = res where+    res = do+        (a,ws) <- evalRWST ans ceEnv 2+        mapM_ addWarning ws+        return a+    ceEnv = CeEnv {+        ceCoerce = tiCoerce tiData,+        ceAssumps = assumps,+        ceFuncs = funcs,+        ceProps = props,+        ceSrcLoc = bogusASrcLoc,+        ceDataTable = dataTable+        }+    Identity funcs = T.mapM (return . EVar . toTVr assumps dataTable) sFuncNames+    Ce ans = do+        nds <- mapM cDecl' hsDecls+        return (map anninst $ concat nds)+    doNegate e = eAp (eAp (func_negate funcs) (getType e)) e+    anninst (a,b,c)+        | "Instance@" `isPrefixOf` show a = (a,setProperty prop_INSTANCE b, deNewtype dataTable c)+        | otherwise = (a,b, deNewtype dataTable c)++    -- first argument builds the actual call primitive, given+    -- (a) the C argtypes+    -- (b) the C return type+    -- (c) the extra return variables passed back in pointers+    -- (d) the arguments themselves+    -- (e) the real return type+    -- ccallHelper returns a function expression to perform the call, when given the arguments+    invalidDecl s = addWarn InvalidDecl s >> fail s+    ccallHelper :: ([ExtType] -> ExtType -> [ExtType] -> [E] -> E -> E) -> E -> C E+    ccallHelper myPrim ty = do+        let (ts,isIO,rt) = extractIO' ty+        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]+        let (rt':ras) = case fromTuple_ rt of+                Just (x:ys@(_:_)) -> (x:ys)+                _ -> [rt]+        ras' <- forM ras $ \t -> ffiTypeInfo ExtTypeVoid t return+        ffiTypeInfo Unknown rt' $ \pt -> do+        cts <- forM  (filter (not . sortKindLike) ts) $ \t -> do ffiTypeInfo ExtTypeVoid t $ return+        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]+        let cFun = createFunc (map tvrType es)+            prim = myPrim (map extTypeInfoExtType cts) (extTypeInfoExtType pt) (map extTypeInfoExtType ras')+        case (isIO,pt,ras') of+            (True,ExtTypeVoid,[]) -> cFun $ \rs -> return (ELam tvrWorld,+                eStrictLet tvrWorld2 (prim (EVar tvrWorld :[EVar t | t <- rs ]) tWorld__)+                    (eJustIO (EVar tvrWorld2) vUnit))+            (False,ExtTypeVoid,_) -> invalidDecl  "pure foreign function must return a non void value"+            (True,_,(_:_)) -> invalidDecl "IO-like functions may not return a tuple"+            (_,ExtTypeBoxed cn rtt' _,[]) -> do+                [rtVar,rtVar'] <- newVars [rt',rtt']+                let rttIO' = ltTuple' [tWorld__, rtt']+                case isIO of+                    False -> cFun $ \rs -> return (id,+                        eStrictLet rtVar' (prim [ EVar t | t <- rs ] rtt')+                            (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }))+                    True -> cFun $ \rs -> return $ (,) (ELam tvrWorld) $+                        eCaseTup' (prim (EVar tvrWorld:[EVar t | t <- rs ]) rttIO') [tvrWorld2,rtVar']+                            (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })+                                (eJustIO (EVar tvrWorld2) (EVar rtVar)))+            (True,ExtTypeRaw  _,[]) -> do+                let rttIO' = ltTuple' [tWorld__, rt']+                cFun $ \rs -> return (ELam tvrWorld,prim (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')+            (False,ExtTypeRaw  _,[]) -> do+                cFun $ \rs -> return (id,prim [EVar t | t <- rs ] rt')+            (False,_,(_:_)) -> do+                let rets = (rt':ras)+                rets' <- mapM unboxedVersion rets+                cFun $ \rs -> do+                fun <- extractUnboxedTup (prim [ EVar t | t <- rs ] (ltTuple' rets')) $ \vs -> do+                    rv <- zipWithM marshallFromC vs rets+                    return $ eTuple' rv+                return (id,fun)+            -- _ -> invalidDecl "foreign declaration is of incorrect form."++    --isExtTypeRaw ExtTypeRaw {} = True+    --isExtTypeRaw _ = False++    cDecl,cDecl' :: HsDecl -> C [(Name,TVr,E)]+    cDecl' d = withSrcLoc (srcLoc d) $ catchError (cDecl d) $ \ (e :: IOError) -> do+        warn (srcLoc d) InvalidDecl $ "caught error processing decl: " ++ show e+        return []+    cDecl (HsForeignDecl sLoc (FfiSpec (Import cn req) _ Primitive) n _) = do+        let name      = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        let (ts,rt)   = argTypes' ty+        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]+        result <- processPrim dataTable sLoc (toAtom cn)+            [ EVar e | e <- es, not (tvrType e == tUnit)] rt req+        return [(name,setProperty prop_INLINE var,+                 lamt $ foldr ($) result (map ELam es))]+    cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do+        let name       = toName Name.Val n+        (var,ty,lamt)  <- convertValue name+        let (_ts,rt)   = argTypes' ty+            expr x     = return [(name,setProperty prop_INLINE var,lamt x)]+            prim       = (AddrOf req $ packString rcn)+        -- this needs to be a boxed value since we can't have top-level+        -- unboxed values yet.+        ffiTypeInfo [] rt $ \eti -> do+        case eti of+            ExtTypeBoxed cn st _ -> do+                [uvar] <- newVars [st]+                expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt }))+            _ -> invalidDecl "foreign import of address must be of a boxed type"++    cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) safe CCall) n _) = do+        let name = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        result <- ccallHelper+                     (\cts crt cras args rt ->+                      EPrim (Func req (packString rcn) cts crt cras safe) args rt)+                     ty+        return [(name,setProperty prop_INLINE var,lamt result)]+    cDecl (HsForeignDecl _ (FfiSpec Dynamic _ CCall) n _) = do+        -- XXX ensure that the type is of form FunPtr /ft/ -> /ft/+        let name = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        --let ((fptrTy:_), _) = argTypes' ty+        --    fty = discardArgs 1 ty+        result <- ccallHelper+                     (\cts crt cras args rt ->+                      EPrim (IFunc mempty (tail cts) crt) args rt)+                     ty+        return [(name,setProperty prop_INLINE var,lamt result)]++    cDecl (HsForeignDecl _ (FfiSpec (Import rcn _) _ DotNet) n _) = do+        (var,ty,lamt) <- convertValue (toName Name.Val n)+        let (ts,isIO,rt') = extractIO' ty+        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]+        ffiTypeInfo [] rt' $ \pt -> do+        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]+        dnet <- parseDotNetFFI rcn+        let cFun = createFunc (map tvrType es)+            prim rs rtt = EPrim dnet+        result <- case (isIO,pt) of+            (True,ExtTypeVoid) -> cFun $ \rs -> return $  (,) (ELam tvrWorld) $+                        eStrictLet tvrWorld2 (prim rs "void" (EVar tvrWorld:[EVar t | t <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)+            (False,ExtTypeVoid) -> invalidDecl "pure foreign function must return a valid value"+            _ -> do+                ExtTypeBoxed cn rtt' rtt <- lookupExtTypeInfo dataTable rt'+                [rtVar,rtVar'] <- newVars [rt',rtt']+                let _rttIO = ltTuple [tWorld__, rt']+                    rttIO' = ltTuple' [tWorld__, rtt']+                case isIO of+                    False -> cFun $ \rs -> return $ (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | t <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })+                    True -> cFun $ \rs -> return $ (,) (ELam tvrWorld) $+                                eCaseTup' (prim rs rtt (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar)))+        return [(toName Name.Val n,var,lamt result)]++    cDecl x@HsForeignDecl {} = invalidDecl ("Unsupported foreign declaration: "++ show x)++    cDecl (HsForeignExport _ ffi@FfiExport { ffiExportCName = ecn } n _) = do+        let name = ffiExportName ffi+        fn <- convertVar name+        tn <- convertVar (toName Name.Val n)++        (var,ty,lamt) <- convertValue name+        let --(argTys,retTy') = argTypes' ty+            --(isIO,retTy) = extractIO' retTy'+            (argTys,isIO,retTy) = extractIO' ty++        --retCTy <- if retTy == tUnit+         --         then return unboxedTyUnit+         --         else liftM (\(_, _, x) -> rawType x) $ lookupCType' dataTable retTy++        aets <- forM argTys $ \ty -> do+            ffiTypeInfo (Unknown,undefined,undefined) ty $ \eti -> do+--            eti <- lookupExtTypeInfo dataTable ty+            ty' <- case eti of+                ExtTypeVoid -> invalidDecl "attempt to foreign export function with void argument"+                ExtTypeRaw _ -> do return ty+                ExtTypeBoxed _ ty' _  -> do return ty'+            [v] <- newVars [ty']+            e <- marshallFromC (EVar v) ty+            return (e,v,ty')++        let argEs   = [ e | (e,_,_) <- aets ]+            argTvrs = [ v | (_,v,_) <- aets ]+            argCTys = [ t | (_,_,t) <- aets ]+        fe <- actuallySpecializeE (EVar tn) ty+        let inner = foldl EAp fe argEs++        retE <- case isIO of+                  False -> marshallToC inner retTy+                  True -> do [world_, world__, ret] <- newVars [tWorld__, tWorld__, retTy]+                             retMarshall <- if retTy == tUnit+                                            then return (ELit (unboxedTuple []))+                                            else marshallToC (EVar ret) retTy+                             return (eLam world_ (eCaseTup' (eAp inner (EVar world_))+                                                            [world__, ret]+                                                            (ELit (unboxedTuple [EVar world__, retMarshall]))))++        let retCTy' = typeInfer dataTable retE++        -- trace ("retE: "++pprint retE) $ return ()++        let result = foldr ELam retE argTvrs++        realRetCTy:realArgCTys <- mapM (\x -> extTypeInfoExtType `liftM`  lookupExtTypeInfo dataTable x) (retTy:argTys)++        return [(name,+                 tvrInfo_u (Info.insert ffi { ffiExportArgTypes = realArgCTys, ffiExportRetType = realRetCTy } )+                           (fmap (const (foldr tFunc retCTy' argCTys)) $+                              setProperty prop_EXPORTED fn),+                 result)]++    cDecl (HsPatBind sl (HsPVar n) (HsUnGuardedRhs exp) []) | n == v_silly = do+        e <- cExpr exp+        return [(v_silly,tvr,e)]+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do+        let name = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        rhs <- cRhs sl rhs+        lv <- hsLetE wh rhs+        return [(name,var,lamt lv)]+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do+        let name = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        rhs <- cRhs sl rhs+        lv <- hsLetE wh rhs+        return [(name,var,lamt lv)]++    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do+        let name = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        rhs <- cRhs sl rhs+        lv <- hsLetE wh rhs+        return [(name,var,lamt lv)]+    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | all isHsPVar ps = do+        let name = toName Name.Val n+        (var,ty,lamt) <- convertValue name+        rhs <- cRhs sl rhs+        lv <- hsLetE wh rhs+        lps <- lp ps lv+        return [(name,var,lamt lps )]+    cDecl (HsFunBind ms@((HsMatch sl n ps _ _):_)) = do+        let name = toName Name.Val n+        (var,t,lamt) <- convertValue name+        let (targs,eargs) = argTypes t+            numberPatterns = length ps+        bs' <- newVars (take numberPatterns eargs)+        let bs  = map EVar bs'+            rt = discardArgs (length targs + numberPatterns) t+            z e = foldr eLam e bs'+        ms <- cMatchs bs (matchesConv ms) (ump sl rt)+        return [(name,var,lamt $ z ms )]+    cDecl cd@(HsClassDecl {}) = cClassDecl cd+    cDecl _ = return []+    cExpr :: HsExp -> C E+    cExpr (HsAsPat n' (HsCon n)) = return $ constructionExpression dataTable (toName DataConstructor n) rt where+        t' = getAssump n'+        (_,rt) = argTypes' (tipe t')+    cExpr (HsLit (HsStringPrim s)) = return $ EPrim (PrimString (packString s)) [] r_bits_ptr_+    cExpr (HsLit (HsString s)) = return $ E.Values.toE s+    cExpr (HsAsPat n' (HsLit (HsIntPrim i))) = ans where+        t' = getAssump n'+        ans = return $ ELit (LitInt (fromIntegral i) (tipe t'))+    cExpr (HsAsPat n' (HsLit (HsCharPrim i))) = ans where+        t' = getAssump n'+        ans = return $ ELit (LitInt (fromIntegral $ ord i) (tipe t'))+    cExpr (HsAsPat n' (HsLit (HsInt i))) = ans where+        t' = getAssump n'+        ty = tipe t'+        -- XXX this can allow us to create integer literals out of things that+        -- arn't in Num if we arn't careful+        ans = case lookupExtTypeInfo dataTable ty of+            Just (ExtTypeBoxed cn st _) -> return $ ELit (litCons { litName = cn, litArgs = [ELit (LitInt (fromIntegral i) st)], litType = ty })+            _ -> return $ intConvert' funcs ty i+            --Just (cn,st,it) ->+    --cExpr (HsLit (HsInt i)) = return $ intConvert i+    cExpr (HsLit (HsChar ch)) = return $ toE ch+    cExpr (HsLit (HsCharPrim ch)) = return $ toEzh ch+    cExpr (HsLit (HsFrac i))  = return $ toE i+    cExpr (HsLambda sl ps e) | all isHsPVar ps = do+        e <- cExpr e+        lp ps e+    cExpr (HsInfixApp e1 v e2) = do+        v <- cExpr v+        e1 <- cExpr e1+        e2 <- cExpr e2+        return $ eAp (eAp v e1) e2+    cExpr (HsLeftSection op e) = liftM2 eAp (cExpr op) (cExpr e)+    cExpr (HsApp (HsRightSection e op) e') = do+        op <- cExpr op+        e' <- cExpr e'+        e <- cExpr e+        return $ eAp (eAp op e') e+    cExpr (HsRightSection e op) = do+        cop <- cExpr op+        ce <- cExpr e+        let (_,TVr { tvrType = ty}:_) = fromPi (getType cop)+        [var] <- newVars [ty]+        return $ eLam var (eAp (eAp cop (EVar var)) ce)+    cExpr (HsApp e1 e2) = liftM2 eAp (cExpr e1) (cExpr e2)+    cExpr (HsParen e) = cExpr e+    cExpr (HsExpTypeSig _ e _) = cExpr e+    cExpr (HsNegApp e) = liftM doNegate (cExpr e)+    cExpr (HsLet dl e) = hsLet dl e+    cExpr (HsIf e a b) = join $ liftM3 createIf (cExpr e) (cExpr a) (cExpr b)+    cExpr (HsCase _ []) = error "empty case"+    cExpr (HsAsPat n HsError { hsExpString = msg }) = do+        ty <- convertTyp (toName Name.Val n)+        return $ EError msg ty+    cExpr (HsAsPat n hs@(HsCase e alts)) = do+        ty <- convertTyp (toName Name.Val n)+        scrut <- cExpr e+        cMatchs [scrut] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  ty)+    cExpr (HsTuple es) = liftM eTuple (mapM cExpr es)+    cExpr (HsUnboxedTuple es) = liftM eTuple' (mapM cExpr es)+    cExpr (HsAsPat n (HsList xs)) = do+        ty <- convertTyp (toName Name.Val n)+        let cl (x:xs) = liftM2 eCons (cExpr x) (cl xs)+            cl [] = return $ eNil ty+        cl xs+    cExpr (HsVar n) = do+        t <- convertVar (toName Name.Val n)+        return (EVar t)+    cExpr (HsAsPat n' e) = do+        e <- cExpr e+        cc <- asks ceCoerce+        case Map.lookup (toName Val n') cc of+            Nothing -> return e+            Just c -> applyCoersion c e+    cExpr e = invalidDecl ("Cannot convert: " ++ show e)+    hsLetE [] e = return  e+    hsLetE dl e = do+        nds <- mconcatMapM cDecl dl+        return $ eLetRec [ (b,c) | (_,b,c) <- nds] e+    hsLet dl e = do+        e <- cExpr e+        hsLetE dl e++    cMatchs :: [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> C E+    cMatchs bs ms els = do+        pg <- processGuards ms+        convertMatches bs pg els++    cGuard (HsUnGuardedRhs e) = liftM const $ cExpr e+    cGuard (HsGuardedRhss (HsGuardedRhs _ g e:gs)) = do+        g <- cExpr g+        e <- cExpr e+        fg <- cGuard (HsGuardedRhss gs)+        [nv] <- newVars [Unknown]+        return (\els -> createIfv nv g e (fg els))+    cGuard (HsGuardedRhss []) = return id++    getAssump n  = case Map.lookup (toName Name.Val n) assumps of+        Just z -> z+        Nothing -> error $ "Lookup failed: " ++ (show n)+    lp  [] e = return e+    lp  (HsPVar n:ps) e = do+        v <- convertVar (toName Name.Val n)+        eLam v `liftM` lp ps e+    lp  p e  =  error $ "unsupported pattern:" <+> tshow p  <+> tshow e+    cRhs sl (HsUnGuardedRhs e) = cExpr e+    cRhs sl (HsGuardedRhss []) = error "HsGuardedRhss: empty"+    cRhs sl (HsGuardedRhss gs@(HsGuardedRhs _ _ e:_)) = f gs where+        f (HsGuardedRhs _ g e:gs) = join $ liftM3 createIf (cExpr g) (cExpr e) (f gs)+        f [] = do+            e <- cExpr e+            return $ ump sl $ getType e+    processGuards xs = flip mapM xs $ \ (ps,e,wh) -> do+        cg <- cGuard e+        nds <- mconcatMapM cDecl wh+        let elet = eLetRec [ (b,c) | (_,b,c) <- nds]+        return (ps,elet . cg )++    cClassDecl (HsClassDecl _ chead decls) = do+        props <- asks ceProps+        let cr = findClassRecord classHierarchy className+            className = hsClassHead chead+            cClass classRecord =  [ f n (toId n) (removeNewtypes dataTable $ tipe t) | (n,t) <- classAssumps classRecord ] where+                f n i t = (n,setProperties [prop_METHOD,prop_PLACEHOLDER] $ tVr i t, foldr ELam (EPrim (primPrim ("Placeholder: " ++ show n)) [] ft) args)  where+                    (ft',as) = fromPi t+                    (args,rargs) = case mlookup i props of+                        Just p | getProperty prop_NOETA p -> span (sortKindLike . getType) as+                        _ -> (as,[])+                    ft = foldr EPi ft' rargs+        return (cClass cr)+    cClassDecl _ = error "cClassDecl"++convertVar n = do+    (t,_,_) <- convertValue n+    return t+convertTyp n = do+    (_,t,_) <- convertValue n+    return t++toTVr assumps dataTable n = tVr (toId n) typeOfName where+    typeOfName = case Map.lookup n assumps of+        Just z -> removeNewtypes dataTable (tipe z)+        Nothing -> error $ "convertVal.Lookup failed: " ++ (show n)++integer_cutoff = 500000000++intConvert i | abs i > integer_cutoff  =  ELit (litCons { litName = dc_Integer, litArgs = [ELit $ LitInt (fromInteger i) r_bits_max_], litType = tInteger })+intConvert i =  ELit (litCons { litName = dc_Int, litArgs = [ELit $ LitInt (fromInteger i) r_bits32], litType = tInt })++intConvert' funcs typ i = EAp (EAp fun typ) (ELit (litCons { litName = con, litArgs = [ELit $ LitInt (fromInteger i) rawtyp], litType = ltype }))  where+    (con,ltype,fun,rawtyp) = case abs i > integer_cutoff of+        True -> (dc_Integer,tInteger,f_fromInteger,r_bits_max_)+        False -> (dc_Int,tInt,f_fromInt,r_bits32)+    f_fromInt = func_fromInt funcs+    f_fromInteger = func_fromInteger funcs++litconvert (HsChar i) t | t == tChar =  LitInt (fromIntegral $ ord i) tCharzh+litconvert (HsCharPrim i) t | t == tCharzh =  LitInt (fromIntegral $ ord i) tCharzh+litconvert (HsIntPrim i) t  =  LitInt (fromIntegral i) t+litconvert e t = error $ "litconvert: shouldn't happen: " ++ show (e,t)++fromHsPLitInt (HsPLit l@(HsInt _)) = return l+fromHsPLitInt (HsPLit l@(HsFrac _)) = return l+fromHsPLitInt x = fail $ "fromHsPLitInt: " ++ show x++tidyPat+    :: HsPat+    -> E+    -> C (HsPat,E -> E)+tidyPat p b = f p where+    f HsPWildCard = return (HsPWildCard,id)+    f (HsPVar n) | isTypePlaceholder n = return (HsPWildCard,id)+    f (HsPAsPat n p) | isTypePlaceholder n = f p+    f (HsPTypeSig _ p _) = f p+    f p@HsPLit {} = return (p,id)+    f (HsPVar n) = do+        v <- convertVar (toName Name.Val n)+        return (HsPWildCard,if EVar v /=  b then eLet v b else id)+    f (HsPAsPat n p) = do+        (p',g') <- f p+        v <- convertVar (toName Name.Val n)+        return (p',(if EVar v /= b then eLet v b else id) . g')+    f pa@(HsPApp n [p]) = do+        dataTable <- getDataTable+        patCons <- getConstructor (toName DataConstructor n) dataTable+        case conChildren patCons of+            DataAlias ErasedAlias -> f p+            _ -> return (pa,id)+    f p@HsPApp {} = return (p,id)+    f (HsPIrrPat (Located ss p)) = f p >>= \ (p',fe) -> case p' of+        HsPWildCard -> return (p',fe)+        _ -> do+            (lbv,bv) <- varify b+            let f n = do+                v <- convertVar (toName Name.Val n)+                fe <- convertMatches [bv] [([p],const (EVar v))] (EError (show ss ++ ": Irrefutable pattern match failed") (getType v))+                return (v,fe)+            zs <- mapM f (getNamesFromHsPat p)+            return (HsPWildCard,lbv . eLetRec zs)+    f ~(HsPBangPat (Located ss (HsPAsPat v p))) = do+        (p',fe) <- f p+        v <- convertVar (toName Name.Val v)+        return (p',eStrictLet v b . fe)++-- converts a value to an updatable closure if it isn't one already.+varify b@EVar {} = return (id,b)+varify b = do+    [bv] <- newVars [getType b]+    return (eLet bv b,EVar bv)++tidyHeads+    :: E+    -> [([HsPat],E->E)]  -- [(pats,else -> value)]+    -> C [(HsPat,[HsPat],E->E)]  -- pulls the head off of each pattern, tidying it up perhaps+tidyHeads b ps = mapM f ps where+    f (~(p:ps),fe) = do+        (p',fe') <- tidyPat p b+        return (p',ps,fe' . fe)++convertMatches+    :: [E]               -- input expressions we are matching against.+    -> [([HsPat],E->E)]  -- [(pats,else -> value)]+    -> E                 -- else, what to do if nothing matches+    -> C E+convertMatches bs ms err = do+    assumps <- asks ceAssumps+    dataTable <- getDataTable+    funcs <- asks ceFuncs+    let fromInt = func_fromInt funcs+        fromInteger = func_fromInteger funcs+        fromRational = func_fromRational funcs+        isJoinPoint (EAp (EVar x) _) | getProperty prop_JOINPOINT x = True+        isJoinPoint _ = False++        match :: [E] -> [([HsPat],E->E)] -> E -> C E+        -- when we run out of arguments, we should run out of patterns. simply fold the transformers.+        match  [] ps err = return $ foldr f err ps where f (~[],fe) err = fe err+        -- when we are out of patterns, return the error term+        match _ [] err = return err+        match ~(b:bs) ps err = do+            (b',mf) <- if isEVar b then return (b,id) else do+                [ev] <- newVars [getType b]+                return $ (EVar ev, eLet ev b)+            pps <- tidyHeads b' ps+            let patternGroups = groupUnder (isHsPWildCard . fst3) pps+                f [] err = return err+                f (ps:pss) err = do+                    err' <- f pss err+                    if isEVar err' || isEError err' || isJoinPoint err' then matchGroup b' bs ps err' else do+                        [ev] <- newVars [EPi tvr { tvrType = unboxedTyUnit } $ getType err']+                        let ev' = setProperties [prop_ONESHOT, prop_JOINPOINT] ev+                        nm <- matchGroup b' bs ps (EAp (EVar ev') unboxedUnit)+                        return $ eLetRec [(ev',ELam (setProperty prop_ONESHOT tvr { tvrType = unboxedTyUnit }) err')] nm+            liftM mf $ f patternGroups err+        matchGroup b bs ps err+            | all (isHsPWildCard . fst3) ps = match bs [ (ps,e) | (_,ps,e) <- ps] err+            | Just () <- mapM_ (fromHsPLitInt . fst3) ps = do+                let tb = getType b+                (lbv,bv) <- varify b+                let gps = [ (p,[ (ps,e) |  (_,ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps]+                    eq = EAp (func_equals funcs) tb+                    f els (HsPLit (HsInt i),ps) = do+                        let ip | abs i > integer_cutoff  = (EAp (EAp fromInteger tb) (intConvert i))+                               | otherwise =  (EAp (EAp fromInt tb) (intConvert i))+                        m <- match bs ps err+                        createIf (EAp (EAp eq bv) ip) m els+                    f els ~(HsPLit (HsFrac i),ps) = do+                        let ip = (EAp (EAp fromRational tb) (toE i))+                        m <- match bs ps err+                        createIf (EAp (EAp eq bv) ip) m els+                e <- foldlM f err gps+                return $ lbv e+            | all (isHsPString . fst3) ps = do+                (lbv,bv) <- varify b+                (eqString,_,_) <- convertValue v_eqString+                (eqUnpackedString,_,_) <- convertValue v_eqUnpackedString+                let gps = [ (p,[ (ps,fe) |  (_,ps,fe) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps]+                    f els (HsPLit (HsString ""),ps) = do+                        m <- match bs ps err+                        return $ eCase bv [Alt (litCons { litName = dc_EmptyList, litType = tString }) m] els+                    f els ~(HsPLit (HsString s),ps) = do+                        m <- match bs ps err+                        let (s',packed) = packupString s+                        if packed+                            then return $ ifzh (EAp (EAp (EVar eqUnpackedString) s') bv) m els+                            else return $ ifzh (EAp (EAp (EVar eqString) s') bv) m els+                e <- foldlM f err gps+                return $ lbv e+            | all (isHsPLit . fst3) ps = do+                let gps = [ (p,[ (ps,fe) |  (_,ps,fe) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps]+                    f (~(HsPLit l),ps) = do+                        m <- match bs ps err+                        return (Alt (litconvert l (getType b)) m)+                as@(_:_) <- mapM f gps+                [TVr { tvrIdent = vr }] <- newVars [Unknown]+                return $ unbox dataTable b vr $ \tvr -> eCase tvr as err+            | Just ps <- mapM pappConvert ps = do+                let gps =  sortGroupUnderF (hsPatName . fst3) ps+                    (Just patCons) = getConstructor (toName DataConstructor $ fst $ head gps) dataTable+                    f (name,ps) = do+                        let spats = hsPatPats $ fst3 (head ps)+                            _nargs = length spats+                        vs <- newVars (slotTypesHs dataTable (toName DataConstructor name) (getType b))+                        ps' <- mapM pp ps+                        m <- match (map EVar vs ++ bs) ps' err+                        deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs m+                    pp (~(HsPApp n ps),rps,e)  = do+                        return $ (ps ++ rps , e)+                as@(_:_) <- mapM f gps+                case conVirtual patCons of+                    Nothing -> return $ eCase b as err+                    Just sibs -> do+                        let (Just Constructor { conChildren = DataNormal [vCons] }) = getConstructor (conInhabits patCons) dataTable+                            (Just Constructor { conOrigSlots = [SlotNormal rtype] }) = getConstructor vCons dataTable+                        [z] <- newVars [rtype]+                        let err' = if length sibs <= length as then Unknown else err+                        return $ eCase b [Alt litCons { litName = vCons, litArgs = [z], litType = getType b } (eCase (EVar z) as err')] Unknown+            | otherwise = error $ "Heterogenious list: " ++ show (map fst3 ps)+        pappConvert (p@HsPApp {},x,y) = return (p,x,y)+        pappConvert (HsPLit (HsString ""),ps,b) = return (HsPApp (nameName $ dc_EmptyList) [],ps,b)+        pappConvert (HsPLit (HsString (c:cs)),ps,b) = return (HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)],ps,b)+        pappConvert _ = fail "pappConvert"+        isHsPString (HsPLit HsString {}) = True+        isHsPString _ = False+    match bs ms err++packupString :: String -> (E,Bool)+packupString s | all (\c -> c > '\NUL' && c <= '\xff') s = (EPrim (PrimString (packString s)) [] r_bits_ptr_,True)+packupString s = (toE s,False)++actuallySpecializeE :: Monad m+    => E   -- ^ the general expression+    -> E   -- ^ the specific type+    -> m E -- ^ the specialized value+actuallySpecializeE ge st = do+    -- trace (pprint (ge, getType ge, st)) $ return ()+    liftM (foldl EAp ge)+          (specializeE (getType ge) st)++specializeE :: Monad m+    => E   -- ^ the general type+    -> E   -- ^ the specific type+    -> m [E]  -- ^ what to apply the general type to to get the specific one+specializeE gt st = do+    let f zs x | Just mm <- match (const Nothing) zs x st = mapM (g mm) (reverse zs) where+            g mm tvr = case lookup tvr mm of+                Just x -> return x+                Nothing -> fail $ "specializeE: variable not bound: " ++ pprint (((gt,st),(mm,tvr)),(zs,x))+        f zs (EPi vbind exp) = f (vbind:zs) exp+        f _ _ = fail $ render (text "specializeE: attempt to specialize types that do not unify:"+                               <$> pprint (gt,st)+                               <$> tshow  gt+                               <$> tshow st)+    f [] gt++procAllSpecs :: Monad m => DataTable -> [Type.Rule] -> [(TVr,E)] -> m ([(TVr,E)],Rules)+procAllSpecs dataTable rs ds = do+    let specMap = Map.fromListWith (++) [ (toId n,[r]) | r@Type.RuleSpec { Type.ruleName = n } <- rs]+        f (t,e) | Just rs <- Map.lookup (tvrIdent t) specMap = do+            hs <- mapM (makeSpec dataTable (t,e)) rs+            return (unzip hs)+        f _ = return mempty+    (nds,rules) <- mconcat `liftM` mapM f ds+    return $ (nds,fromRules rules)++makeSpec :: Monad m => DataTable -> (TVr,E) -> T.Rule -> m ((TVr,E),Rule)+makeSpec dataTable (t,e) T.RuleSpec { T.ruleType = rt, T.ruleUniq = (Module m,ui), T.ruleSuper = ss } = do+    let nt = removeNewtypes dataTable $ tipe rt+    as <- specializeE (getType t) nt+    let ntvr = tvr { tvrIdent = toId newName, tvrType = getType nbody, tvrInfo = setProperties (prop_SPECIALIZATION:sspec) mempty }+        Just nn = fromId (tvrIdent t)+        (ntype,Just (show -> m),q) = nameParts nn+        newName = toName ntype (Just $ toModule ("Spec@." ++ m ++ "." ++ show ui),'f':m ++ "." ++ q)+        sspec = if ss then [prop_SUPERSPECIALIZE] else []+        ar = makeRule ("Specialize.{" ++ show newName) (toModule m,ui) RuleSpecialization bvars t as (foldl eAp (EVar ntvr) (map EVar bvars))+        bvars = nub $ freeVars as+        nbody = foldr ELam (foldl EAp e as) bvars+    return ((ntvr,nbody),ar)+makeSpec _ _ _ = fail "E.FromHs.makeSpec: invalid specialization"++deNewtype :: DataTable -> E -> E+deNewtype dataTable e = removeNewtypes dataTable (f e) where+    f ECase { eCaseScrutinee = e, eCaseAlts = ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == DataAlias ErasedAlias = f (eLet v e z) where+        Identity Constructor { conChildren = alias } = getConstructor n dataTable+    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == DataAlias RecursiveAlias = f $ eLet v (prim_unsafeCoerce e (getType v)) z where+        Identity Constructor { conChildren = alias } = getConstructor n dataTable+    f e = runIdentity $ emapE (return . f) e++ffiTypeInfo bad t cont = do+    dataTable <- getDataTable+    case lookupExtTypeInfo dataTable t of+        Just r -> cont r+        Nothing -> do+            sl <- getSrcLoc+            liftIO $ warn sl InvalidFFIType $ printf "Type '%s' cannot be used in a foreign declaration" (pprint t :: String)+            return bad++unboxedVersion t = do+    ffiTypeInfo Unknown t $ \eti -> case eti of+        ExtTypeBoxed _ uv _ -> return uv+        ExtTypeRaw _ -> return t+        ExtTypeVoid -> return (eTuple' [])++marshallToC e te = do+    ffiTypeInfo Unknown te $ \eti -> do+    case eti of+        ExtTypeBoxed cna sta _ -> do+            [tvra] <- newVars [sta]+            return $ eCase e+                           [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })+                                (EVar tvra)]+                           Unknown+        ExtTypeRaw _ -> return e+        ExtTypeVoid -> fail "marshallToC: trying to marshall void"+marshallFromC ce te = do+    ffiTypeInfo Unknown te $ \eti -> do+    case eti of+        ExtTypeBoxed cna _ _ -> return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })+        ExtTypeRaw _ -> return ce+        ExtTypeVoid -> fail "marshallFromC: trying to marshall void"++extractUnboxedTup :: E -> ([E] -> C E) -> C E+extractUnboxedTup e f = do+    vs <- newVars $ concat (fromTuple_ (getType e))+    a <- f (map EVar vs)+    return $ eCaseTup' e vs a
+ src/E/Inline.hs view
@@ -0,0 +1,154 @@+module E.Inline(+    app,+    programMapRecGroups,+    forceInline,+    programDecomposedDs,+    programDecomposedCombs,+    programMapProgGroups,+    forceNoinline,+    baseInlinability+    ) where++import Control.Monad.Writer++import E.Annotate+import E.E+import E.Program+import E.Subst+import E.Values+import Info.Info(Info)+import Info.Types+import Options+import Stats+import StringTable.Atom+import Support.FreeVars+import Util.Graph+import Util.SetLike+import qualified FlagOpts as FO++-- | higher numbers mean we want to inline it more+baseInlinability t e+    | forceNoinline t = -15+    | forceSuperInline t = 10+    | forceInline t = 7+    | isAtomic e = 6+    | whnfOrBot e = 4+    | otherwise = 0++-- NOINLINE must take precidence because it is sometimes needed for correctness, while INLINE is surely an optimization.+forceInline :: HasProperties a => a -> Bool+forceInline x+    | forceNoinline props = False+    | getProperty prop_WRAPPER props = True+    | not (fopts FO.InlinePragmas) = False+    | otherwise  = fromList [prop_INLINE,prop_SUPERINLINE] `intersects` props+    where props = getProperties x++forceSuperInline :: HasProperties a => a -> Bool+forceSuperInline x+    | forceNoinline props = False+    | not (fopts FO.InlinePragmas) = False+    | otherwise = member prop_SUPERINLINE props+    where props = getProperties x++forceNoinline :: HasProperties a => a -> Bool+forceNoinline x  = fromList [prop_HASRULE,prop_NOINLINE,prop_PLACEHOLDER] `intersects` getProperties x++app (e,[]) = return e+app (e,xs) = app' e xs++app' (ELit lc@LitCons { litName = n, litArgs = xs, litType = EPi ta tt }) (a:as)  = do+    mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" )+    app (ELit (lc { litArgs = xs ++ [a], litType = subst ta a tt }),as)+app' (ELit LitCons { litName = n, litArgs = es, litAliasFor = Just af }) bs@(_:_) = do+    mtick (toAtom $ "E.Simplify.newtype-reduce.{" ++ show n ++ "}" )+    app (foldl eAp af (es ++ bs),[])+app' (ELam tvr e) (a:as) = do+    mtick (toAtom "E.Simplify.beta-reduce")+    app (subst tvr a e,as)   -- TODO Fix quadradic substitution+    --app (eLet tvr a e,as)   -- TODO Fix quadradic substitution+app' (EPi tvr e) (a:as) = do+    mtick (toAtom "E.Simplify.pi-reduce")+    app (subst tvr a e,as)     -- Okay, types are small+app' ec@ECase {} xs = do+    mtick (toAtom "E.Simplify.case-application")+    let f e = app' e xs+    ec' <- caseBodiesMapM f ec+    let t = foldl eAp (eCaseType ec') xs+    return $ caseUpdate ec' { eCaseType = t }+app' (ELetRec ds e) xs = do+    mtick (toAtom "E.Simplify.let-application")+    e' <- app' e xs+    return $ eLetRec ds e'+app' (EError s t) xs = do+    mtick (toAtom "E.Simplify.error-application")+    return $ EError s (foldl eAp t xs)+app' e as = do+    return $ foldl EAp e as++-- | Map recursive groups, allowing an initial map to be passed in and it will+-- also propagate changes in the tvrInfo properly, and make sure nothing+-- shadows one of the global names.++programMapRecGroups :: Monad m =>+    IdMap (Maybe E)        -- ^ initial map to apply+    -> (Id -> Info -> m Info)   -- ^ annotate based on Id map+    -> (E -> Info -> m Info)    -- ^ annotate letbound bindings+    -> (E -> Info -> m Info)    -- ^ annotate lambdabound bindings+    -> ((Bool,[Comb]) -> m [Comb])  -- ^ bool is true if group is recursive.+    -> Program+    -> m Program+programMapRecGroups imap idann letann lamann f prog = do+    let g rs imap ((False,ds):rds) = do+            ds' <- annotateCombs imap idann letann lamann ds+            nds <- f (False,ds')+            g (nds:rs) (bm nds imap) rds+        g rs imap ((True,ds):rds) = do+            ds' <- annotateCombs imap idann letann lamann ds+            nds <- f (True,ds')+            let imap' = (bm nds imap)+            let smap = substMap' $ fromList [ (combIdent  x,EVar (combHead  x)) | x <- nds]+                nds' = [ combBody_u smap x | x <- nds]+            g (nds':rs) imap' rds+        g rs _ [] = return $ concat rs+        bm xs imap = fromList [ (combIdent c,Just $ EVar (combHead c)) | c <- xs ] `union` imap+    ds <- g [] imap $ programDecomposedCombs prog+    return $ programUpdate $ prog { progCombinators = ds }++programDecomposedCombs :: Program -> [(Bool,[Comb])]+programDecomposedCombs prog = map f $ scc g where+    --g = newGraph (progCombinators prog) combIdent ( toList . (union $ progSeasoning prog) . (freeVars :: Comb -> IdSet))+    g = newGraph (progCombinators prog) combIdent ( toList . (freeVars :: Comb -> IdSet))+    f (Left c) = (False,[c])+    f (Right cs) = (True,cs)++programDecomposedDs :: Program -> [Either (TVr, E) [(TVr,E)]]+programDecomposedDs prog = decomposeDs $ programDs prog++programSubProgram prog rg ds = progCombinators_s ds prog {  progType = SubProgram rg, progEntry = fromList (map combIdent ds) }++programMapProgGroups :: Monad m =>+    IdMap (Maybe E)        -- ^ initial map to apply+    -> (Program -> m Program)+    -> Program+    -> m Program+programMapProgGroups imap f prog = do+    let g prog' rs imap ((False,ds):rds) = do+            ds' <- annotateCombs imap nann nann nann ds+            nprog <- f (programSubProgram prog' False ds')+            let nds = progCombinators nprog+            g (unames nds nprog) (nds:rs) (bm nds imap) rds+        g prog' rs imap ((True,ds):rds) = do+            ds' <- annotateCombs imap nann nann nann ds+            nprog <- f (programSubProgram prog' True ds')+            let imap' = bm nds imap+                smap = substMap' $ fromList [ (combIdent  x,EVar (combHead  x)) | x <- nds]+                nds = progCombinators nprog+                nds' = [ combBody_u smap x | x <- nds]+            g (unames nds' nprog) (nds':rs) imap' rds+        g prog' rs _ [] = return $ (concat rs,prog')+        bm xs imap = fromList [ (combIdent c,Just $ EVar (combHead c)) | c <- xs ] `union` imap+        nann _ = return+        unames ds prog = prog { progExternalNames = progExternalNames prog `mappend` fromList (map combIdent ds) }+    (ds,prog'') <- g prog { progStats = mempty } [] imap $ programDecomposedCombs prog+    return $ programUpdate $ prog { progCombinators = ds, progStats = progStats prog `mappend` progStats prog'' }
+ src/E/LetFloat.hs view
@@ -0,0 +1,328 @@+module E.LetFloat(+    atomizeApps,+    atomizeAp,+    floatOutward,+    programFloatInward,+    floatInward+  ) where++import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Typeable+import Data.List  hiding(delete,insert)+import qualified Data.Map as Map++import DataConstructors+import Doc.PPrint+import E.E+import E.Inline+import E.Program+import E.Subst+import E.Traverse+import E.TypeCheck+import E.Values+import GenUtil+import Info.Types+import Name.Id+import Name.Name+import Options+import Stats+import Support.CanType+import Support.FreeVars+import Util.SetLike+import Util.UniqueMonad()+import qualified Info.Info as Info+import qualified Util.Graph as G++atomizeApps ::+    Bool          -- ^ whether to atomize type arguments+    -> Program+    -> Program+atomizeApps atomizeTypes prog = ans where+    Identity ans = programMapBodies (return . atomizeAp mempty atomizeTypes (progDataTable prog)) prog++atomizeAp :: IdSet -> Bool -> DataTable -> E -> E+atomizeAp inscope atomizeTypes dataTable e = runReader (f e) inscope where+    f ELetRec { eDefs = [], eBody = e } = f e+    f ep@(ELam TVr { tvrIdent = i } _) = local (insert i) $ emapEG f return ep+    f el@ELetRec { eDefs = ds } = local (`mappend` fromList (map (tvrIdent . fst) ds)) $ emapEG f return el+    f ec@ECase {} = local (`mappend` fromList (map tvrIdent (caseBinds ec))) $ emapEG f return ec+    f (ELit lc@LitCons { litArgs = xs }) = mapM f xs >>= dl (\xs -> ELit lc { litArgs = xs })+    f ep@(EPi tvr@TVr {tvrIdent = i, tvrType = t} b) | i == emptyId || i `notMember` freeIds b  = do+        t <- f t+        b <- f b+        dl (\ [t,b] -> EPi tvr { tvrIdent = emptyId, tvrType = t } b) [t,b]+    f ep@(EPi  TVr { tvrIdent = i } _) = local (insert i) $ emapEG f return ep+    f (EPrim n xs t) = mapM f xs >>= dl (\xs -> EPrim n xs t)+    f e = case fromAp e of+        (x,xs) -> do+            x <- emapEG f return x+            mapM f xs >>= dl (\xs -> foldl EAp x xs)+    dl build xs = do+        (fn,xs') <- h xs+        return $ fn (build xs')+    h :: [E] -> Reader IdSet (E -> E,[E])+    h (e:es) | isAtomic e = h es >>= \ (fn,es') -> return (fn,e:es')+    h (e:es) = do+        fvs <- ask+        let (var:_) = [ i | i <- newIds fvs]+            tvt = infertype dataTable e+            tv = tvr { tvrIdent = var, tvrType = tvt }+            fn = if getType tvt == eHash then eStrictLet tv e else eLetRec [(tv,e)]+        (fn',es') <- local (insert var) (h es)+        return (fn . fn',EVar tv:es')+    h [] = return (id,[])+    isAtomic :: E -> Bool+    isAtomic EVar {}  = True+--    isAtomic (EAp e v) | not atomizeTypes && isAtomic e && sortTypeLike v = True+    isAtomic e | not atomizeTypes && sortTypeLike e = True+    isAtomic e = isFullyConst e++fvBind (Left (_,fv)) = fv+fvBind (Right xs) = unions (snds xs)++canFloatPast t | sortKindLike . getType $ t = True+--canFloatPast t | getType t == tWorldzh = True+canFloatPast t | isState_ (getType t) = True+canFloatPast t | getProperty prop_ONESHOT t = True+canFloatPast _ = False++{-# NOINLINE programFloatInward #-}+programFloatInward :: Program -> IO Program+programFloatInward prog = do+    let binds = G.scc $  G.newGraph [ (c ,freeVars c) | c <- progCombinators prog, combIdent c  `notElem` map combIdent epoints ] (combIdent . fst) (idSetToList . snd)+        epoints = [ c | c@Comb { combHead = x } <- progCombinators prog, (tvrIdent x `member` progEntry prog) || forceNoinline x || getProperty prop_INSTANCE x || getProperty prop_SPECIALIZATION x ]+        (oall,pints) = sepByDropPoint dpoints  (reverse binds)+        dpoints = map freeVars epoints+        nprog = progCombinators_s ([ combBody_u (\v -> fi c v y) c | (c,y) <- zip epoints pints] ++ [ combBody_u (\y -> floatInwardE y []) c | c <- dsBinds oall]) prog+        fi k = if getProperty prop_ONESHOT k then floatInwardE' else floatInwardE+    --mapM_ (putStrLn . pprint) (map fst $ dsBinds (concat pints))+    --Prelude.print (cupbinds binds)+    --Prelude.print dpoints+    --Prelude.putStrLn (pprint $ map fst (dsBinds binds))+    --Prelude.putStrLn (pprint $ (map fst $ dsBinds oall,map (\binds -> map fst $ dsBinds binds) pints))+    let mstats = mconcat [ Stats.singleton $ "FloatInward.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds (concat pints)]+        mstats' = mconcat [ Stats.singleton $ "FloatInward.all.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds oall]+        nstats = progStats prog `mappend` mstats `mappend` mstats'+    --nprog <- programMapBodies (return . floatInward) nprog+    return nprog { progStats = nstats }++--cupbinds bs = f bs where+--    f (Left ((t,_),fv):rs) = (tvrShowName t,fv):f rs+--    f (Right ds:rs) = f $ map Left ds ++ rs+--    f [] = []++floatInward+    :: E  -- ^ input term+    -> E  -- ^ output term+floatInward e = floatInwardE e []++floatInwardE :: E -> Binds -> E+floatInwardE e fvs = f e fvs where+    f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault =  d } xs = ans where+        ans = letRec p' $ caseUpdate ec { eCaseScrutinee = (f e pe), eCaseAlts = [ Alt l (f e pn) | Alt l e <- as | pn <- ps ], eCaseDefault = (fmap (flip f pd) d)}+        (p',_:pe:pd:ps) = sepByDropPoint (mconcat [freeVars l | Alt l _ <- as ]:freeVars e: tvrIdent b `delete` freeVars d :[freeVars a | a <- as ]) xs+    f ELetRec { eDefs = ds, eBody = e } xs = g (G.scc $  G.newGraph [ (bindComb d,freeVars $ bindComb d) | d <- ds ] (combIdent . fst) (idSetToList . snd) ) xs where+        g [] p' = f e p'+        g ((Left (comb@Comb { combHead = v, combBody = ev},fv)):xs) p = g xs (p0 ++ [Left (comb',freeVars comb')] ++ p') where+            comb' = combBody_s ev' comb+            ev' = if getProperty prop_ONESHOT v then floatInwardE' ev pv else f ev pv+            (p',[p0,pv,_]) = sepByDropPoint [(frest xs), freeVars comb, freeVars (tvrType v)] p+        g (Right bs:xs) p =  g xs (p0 ++ [Right [ let comb' = combBody_u (\ev -> f ev pv) comb in (comb',freeVars comb') | (comb,_) <- bs | pv <- ps ]] ++ p') where+            (p',_:p0:ps) = sepByDropPoint (freeVars (map (tvrType . combHead . fst) bs) :(frest xs):snds bs) p+        frest xs = mconcat (freeVars e:map fvBind xs)+    f e@ELam {} xs | all canFloatPast  ls = (foldr ELam (f b xs) ls) where+        (b,ls) = fromLam e+    f e@ELam {} xs = letRec unsafe_to_dup (foldr ELam (f b safe_to_dup) ls) where+        (unsafe_to_dup,safe_to_dup) = sepDupableBinds (freeVars ls) xs+        (b,ls) = fromLam e+    f e (Left (Comb { combHead = v', combBody = ev},_):xs)+        | (EVar v,as) <- fromAp e, v == v', not (tvrIdent v' `member` (freeVars as :: IdSet))  = f (runIdentity $ app (ev,as)) xs+    f e xs = letRec xs e+    letRec [] e = e+    letRec xs e = f (G.scc $ G.newGraph (concatMap G.fromScc xs) (combIdent . fst) (idSetToList . snd)) where+        f [] = e+        f (Left (te,_):rs) = eLetRec [combBind te] $ f rs+        f (Right ds:rs) = eLetRec (map (combBind . fst) ds) $ f rs++floatInwardE' e@ELam {} xs  = (foldr ELam (floatInwardE b xs) ls) where+    (b,ls) = fromLam e+floatInwardE' e xs = floatInwardE e xs++type FVarSet = IdSet+type Binds = [Either (Comb,FVarSet) [(Comb,FVarSet)]]++dsBinds bs = foldr ($) [] (map f bs) where+    f (Left (x,_)) = (x:)+    f (Right ds) = (map fst ds ++)++sepDupableBinds :: [Id] -> Binds -> (Binds,Binds)+sepDupableBinds fvs xs = partition ind xs where+    g = G.reachableFrom  (combIdent . fst) (idSetToList . snd) (concatMap G.fromScc xs ) (fvs `mappend` unsafe_ones)+    uso = map (combIdent . fst) g+    unsafe_ones = concat [ map (combIdent . fst) vs | vs <- map G.fromScc xs,any (not . isCheap) (map (combBody . fst) vs)]+    ind x = any ( (`elem` uso) . combIdent . fst ) (G.fromScc x)++-- | seperate bindings based on whether they can be floated inward+sepByDropPoint ::+    [FVarSet]           -- ^ list of possible drop points+    -> Binds            -- ^ list of bindings and their free variables+    -> (Binds,[Binds])  -- ^ bindings seperated into those which must be dropped outside of all drop points, and those which can be floated inward into each branch+sepByDropPoint ds [] = ([], [ [] | _ <- ds ])+--sepByDropPoint ds fs' | sameShape1 xs ds && sum (length r:map length xs) <= length fs' = (r,xs) where+sepByDropPoint ds fs' = (r,xs) where+    (r,xs) = f fs'+    f [] = ([], [ [] | _ <- ds ])+    f (b:bs)+        | nu == 0 = f bs+        | nu == 1 =   case sepByDropPoint [ if v then d `mappend` fb' else d | (d,v) <- ds'  ] bs of+            (gb,ds'')  -> (gb, [ if v then b:d else d | d <- ds'' | (_,v) <- ds' ])+            -- (gb,ds'') | sameShape1 ds' ds'' -> (gb, [ if v then b:d else d | d <- ds'' | (_,v) <- ds' ])+        | otherwise = case sepByDropPoint [ d `mappend` fb' | d <- ds  ] bs of+            (gb,ds'')  -> (b:gb,ds'')+            --(gb,ds'') | sameShape1 ds'' ds -> (b:gb,ds'')+      where+        fb' = fvBind b+        ds' = [ (d,any  (`member` d) (fvDecls b)) | d <- ds ]+        nu = length (filter snd ds')+    fvDecls (Left (c,_)) = [combIdent c]+    fvDecls (Right ts) = [combIdent c | (c,_) <- ts ]++newtype Level = Level Int+    deriving(Eq,Ord,Enum,Show,Typeable)++newtype CLevel = CLevel Level+    deriving(Eq,Ord,Enum,Show,Typeable)++top_level = Level 0++--notFloatOut e = isAtomic e || whnfOrBot e+notFloatOut e = False++floatOutward :: Program -> IO Program+floatOutward prog = do+    -- annotate bindings with their levels+    let tl (t,e) imap = (tvrInfo_u (Info.insert top_level) t,g imap top_level e)+        g imap n e = gg e where+            gg e@ELam {} = foldr ELam (g imap' n' b) ts' where+                (b,ts) = fromLam e+                n' = succ n+                ts' = map (tvrInfo_u (Info.insert n')) ts+                imap' = Map.fromList [ (tvrIdent t,n') | t <- ts] `Map.union` imap+            gg ec@ECase {} = caseBodiesMap (\e -> g imap' n e) ec { eCaseScrutinee = gg (eCaseScrutinee ec), eCaseBind = m (eCaseBind ec), eCaseAlts = map ma (eCaseAlts ec) } where+                m t = tvrInfo_u (Info.insert n) t+                ma (Alt lc@LitCons { litName = n, litArgs = xs, litType = t }  b) = Alt lc { litArgs = map m xs } b+                ma a = a+                imap' = Map.fromList [ (tvrIdent t,n) | t <- caseBinds ec] `Map.union` imap+            gg ELetRec { eDefs = ds, eBody = e } = dds (map G.fromScc $ decomposeDs ds) [] e imap where+                dds (ts:rs) nrs e imap = dds rs (ts':nrs) e imap' where+                    n' = maximum (Level 1:[ lup t | t <- fvs ])+                    lup n = case Map.lookup n imap of+                        Just x -> x+                        Nothing -> error $ "LetFloat: could not find " ++ show tvr { tvrIdent = n }+                    cl = CLevel n+                    fvs = [ t | t <- freeVars ts, t `notElem` (map (tvrIdent . fst) ts)]+                    ts' = [(tvrInfo_u (Info.insert cl . Info.insert n') t,g imap' n e) |  (t,e) <- ts]+                    imap' = Map.fromList [ (tvrIdent t,n') | t <- fsts ts] `Map.union` imap+                dds [] nrs e imap = ELetRec (concat nrs) (g imap n e)+            gg e = runIdentity $ (emapE' (\e -> return $ gg e) e)+    let imap = Map.fromList $ map (\x -> (x,top_level)) ([ tvrIdent t| (t,_) <-  programDs prog ] +++            idSetToList (progExternalNames prog `mappend` progSeasoning prog))+    prog <- flip programMapDs prog (\ (t,e) -> do+        e' <- letBindAll (progDataTable prog) (progModule prog) e+        return $ tl (t,e') imap)++    -- perform floating based on previous annotations+    let dofloat ELetRec { eDefs = ds, eBody = e } = do+            e' <- dofloat e+            ds' <- mapM df ds+            return (ELetRec (concat ds') e')+        dofloat e@ELam {} = do+            let (b,ts) = fromLam e+                Just ln = Info.lookup (tvrInfo (head ts))+            (b',fs) <- censor (const []) $ listen (dofloat b)+            let (dh,de) = partition (\ (ll,bn) -> succ ll == ln) fs+            tell de+            return $ letRec (snds dh) (foldr ELam b' ts)+        dofloat e = emapE' dofloat e+        df (t,e) | Just (CLevel cl) <- lcl, cl /= nl = ans where+            ans = do+                e' <- dofloat e+                mtick $ "LetFloat.Full-Lazy.float.{" ++ maybeShowName t+                tell [(nl,(t,e'))]+                return []+            lcl = Info.lookup (tvrInfo t)+            Just nl = Info.lookup (tvrInfo t)+        df (t,e) = do+            e' <- dofloat e+            return [(t,e')]+--        dtl (t,ELetRec ds e) = do+--            (e',fs) <- runWriterT (dofloat e)+--            return $ (t,e'):snds fs+        dtl comb = do+            (e,fs) <- runWriterT (dofloat $ combBody comb)+            let (e',fs') = case e of+                    ELetRec { eDefs = ds, eBody = e } -> (e,ds++snds fs)+                    _ -> (e,snds fs)+                -- we imediatly float inward to clean up cruft and spurious outwards floatings+                (e'',fs'') = cDefs $ floatInward (ELetRec fs' e')+                cDefs (ELetRec ds e) = (e',ds ++ ds') where+                    (e',ds') = cDefs e+                cDefs e = (e,[])+            flip mapM_ (fsts $ fs'') $ \t -> do+                mtick $ "LetFloat.Full-Lazy.top_level.{" ++ maybeShowName t+            u <- newUniq+            let (fs''',sm') = unzip [ ((n,sm e),(t,EVar n)) | (t,e) <- fs'', let n = nn t ]+                sm = substLet sm'+                nn tvr = tvr { tvrIdent = toId $ lfName u (progModule prog) Val (tvrIdent tvr) }+            return $ combBody_s (sm e'') comb:map bindComb fs'''+    (cds,stats) <- runStatT (mapM dtl $ progCombinators prog)+    let nprog = progCombinators_s (concat cds) prog+    return nprog { progStats = progStats nprog `mappend` stats }++maybeShowName t = if '@' `elem` n then "(epheremal)" else n where+    n = tvrShowName t++lfName u modName ns x = case fromId x of+    Just y  -> toName ns (show modName, "fl@"++show y ++ "$" ++ show u)+    Nothing -> toName ns (show modName, "fl@"++show x ++ "$" ++ show u)++mapMSnd f xs = sequence [ (,) x `liftM` f y | (x,y) <- xs]++letBindAll+    :: DataTable  -- ^ the data table for expanding newtypes+    -> Module     -- ^ current module name+    -> E          -- ^ input term+    -> IO E+letBindAll  dataTable modName e = f e  where+    f :: E -> IO E+    f ELetRec { eDefs = ds, eBody = e } = do+        ds' <- mapMSnd f ds+        e' <- g e+        return $ ELetRec ds' e'+    f ec@ECase {} = do+        let mv = case eCaseScrutinee ec of+                EVar v -> subst (eCaseBind ec) (EVar v)+                _ -> id+        ec' <- caseBodiesMapM (fmap mv . g) ec+        scrut' <- g (eCaseScrutinee ec)+        return $ caseUpdate ec' { eCaseScrutinee = scrut' }+    f e@ELam {} = do+        let (b,ts) = fromLam e+        b' <- g b+        return (foldr ELam b' ts)+    f e = emapE' f e+    g e | notFloatOut e = return e+    g e | isUnboxed (getType e) = return e+    g e = do+        u <- newUniq+        let n = toName Val (show modName,"af@" ++ show u)+            tv = tvr { tvrIdent = toId n, tvrType = infertype dataTable e }+        e' <- f e+        return (ELetRec [(tv,e')] (EVar tv))++letRec [] e = e+letRec ds _ | flint && hasRepeatUnder fst ds = error "letRec: repeated variables!"+letRec ds e | flint && any (isUnboxed .tvrType . fst) ds = error "letRec: binding unboxed!"+letRec ds e = ELetRec ds e
+ src/E/Lint.hs view
@@ -0,0 +1,156 @@+module E.Lint(+    transformProgram,+    onerrNone,+    lintCheckProgram,+    dumpCore+    ) where++import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Data.List as List+import Data.Maybe+import Support.Compat+import qualified Data.Set as Set++import Data.Monoid+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.E+import E.Program+import E.Show+import E.Traverse+import E.TypeCheck+import Name.Id+import Options+import Stats+import Support.FreeVars+import Support.TempDir+import Support.Transform+import Util.ContextMonad+import Util.Gen+import Util.SetLike as S+import qualified FlagDump as FD+import qualified System.IO++-- all transformation routines assume they are being passed a correct program, and only check the output++transformProgram :: MonadIO m => TransformParms Program -> Program -> m Program++transformProgram TransformParms { transformIterate = IterateMax n } prog | n <= 0 = return prog+transformProgram TransformParms { transformIterate = IterateExactly n } prog | n <= 0 = return prog+transformProgram tp prog = liftIO $ do+    let dodump = transformDumpProgress tp+        name = transformCategory tp ++ pname (transformPass tp) ++ pname (transformName tp)+        scname = transformCategory tp ++ pname (transformPass tp)+        pname "" = ""+        pname xs = '-':xs+        iterate = transformIterate tp+    withStackStatus ("transformProgram: " ++ name) $ do+    when dodump $ putErrLn $ "-- " ++ name+    when (dodump && dump FD.CorePass) $ printProgram prog+    wdump FD.ESize $ printESize ("Before "++name) prog+    let istat = progStats prog+    let ferr e = do+        putErrLn $ "\n>>> Exception thrown"+        dumpCoreExtra ("lint-before-" ++ name) prog (show (e::SomeException'))+        putErrLn (show (e::SomeException'))+        maybeDie+        return prog+    prog' <- Control.Exception.catch (transformOperation tp prog { progStats = mempty }) ferr+    let estat = progStats prog'+        onerr = do+            putErrLn $ "\n>>> Before " ++ name+            dumpCore ("lint-before-" ++ name) prog+            Stats.printStat name estat+            putErrLn $ "\n>>> After " ++ name+            let fvs = programFreeVars prog' `mappend` programFreeVars prog+                rtvrs = "FreeVars:\n" ++ (render $ vcat $ map (\tvr -> hang 4 (pprint (tvr :: TVr) <+> text "::" <+> (pprint $ tvrType tvr))) fvs)+            dumpCoreExtra ("lint-after-" ++ name) prog' rtvrs+    if transformSkipNoStats tp && estat == mempty then do+        when dodump $ putErrLn "program not changed"+        return prog+     else do+    when (dodump && dump FD.CoreSteps && (not $ Stats.null estat)) $ Stats.printLStat (optStatLevel options) name estat+    when verbose $ do+        Stats.tick Stats.theStats scname+        Stats.tickStat Stats.theStats (Stats.prependStat scname estat)+    wdump FD.ESize $ printESize ("After  "++name) prog'+    lintCheckProgram onerr prog'+    if doIterate iterate (not $ Stats.null estat) then transformProgram tp { transformIterate = iterateStep iterate } prog' { progStats = istat `mappend` estat } else+        return prog' { progStats = istat `mappend` estat, progPasses = name:progPasses prog' }++maybeDie = case optKeepGoing options of+    True -> return ()+    False -> putErrDie "Internal Error"++onerrNone :: IO ()+onerrNone = return ()++lintCheckE onerr dataTable tvr e | flint = case runContextEither $ inferType dataTable [] e of+    Left ss -> do+        onerr+        putErrLn ">>> Type Error"+        putErrLn  ( render $ hang 4 (pprint tvr <+> equals <+> pprint e))+        putErrLn $ "\n>>> internal error:\n" ++ unlines (intersperse "----" $ tail ss)+        maybeDie+    Right v -> return ()+lintCheckE _ _ _ _ = return ()++lintCheckProgram onerr prog | flint = do+    when (hasRepeatUnder fst (programDs prog)) $ do+        onerr+        let repeats = [ x | x@(_:_:_) <- List.group $ sort (map fst (programDs prog))]+        putErrLn $ ">>> Repeated top level decls: " ++ pprint repeats+        printProgram prog+        putErrLn $ ">>> program has repeated toplevel definitions" ++ pprint repeats+        maybeDie+    let f (tvr@TVr { tvrIdent = n },e) | isNothing $ fromId n = do+            onerr+            putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr+            printProgram prog+            putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr+            maybeDie+        f (tvr,e) = do+            case scopeCheck False mempty e of+                Left s -> do+                    onerr+                    putErrLn $ ">>> scopecheck failed in " ++ pprint tvr ++ " " ++ s+                    printProgram prog+                    putErrLn $ ">>> scopecheck failed in " ++ pprint tvr ++ " " ++ s+                    maybeDie+                Right () -> return ()+            lintCheckE onerr (progDataTable prog) tvr e+    mapM_ f (programDs prog)+    let ids = progExternalNames prog `mappend` fromList (map tvrIdent $ fsts (programDs prog)) `mappend` progSeasoning prog+        fvs = Set.fromList $ values (freeVars $ snds $ programDs prog :: IdMap TVr)+        unaccounted = Set.filter (not . (`member` ids) . tvrIdent) fvs+    unless (Set.null unaccounted) $ do+        onerr+        putErrLn ("\n>>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))+        printProgram prog+        putErrLn (">>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))+        maybeDie+lintCheckProgram _ _ = return ()++programFreeVars prog = freeVars (ELetRec (programDs prog) Unknown)++dumpCore pname prog = dumpCoreExtra pname prog ""++dumpCoreExtra pname prog extra = do+    let fn = outputName ++ "_" ++ pname ++ ".jhc_core"+    putErrLn $ "Writing: " ++ fn+    h <- System.IO.openFile fn System.IO.WriteMode+    (argstring,sversion) <- getArgString+    System.IO.hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]+    hPrintProgram h prog+    System.IO.hPutStrLn h extra+    System.IO.hClose h+    wdump FD.Core $ do+        putErrLn $ "v-- " ++ pname ++ " Core"+        printProgram prog+        putErrLn $ "^-- " ++ pname ++ " Core"++printESize :: String -> Program -> IO ()+printESize str prog = putErrLn $ str ++ " program e-size: " ++ show (eSize (programE prog))
+ src/E/Main.hs view
@@ -0,0 +1,586 @@+-- this file contains the main driver for the core->core optimizations++module E.Main(processInitialHo,processDecls,compileWholeProgram,dumpRules) where++import Control.Exception+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import System.Mem+import qualified Data.Map as Map+import qualified Data.Set as Set++import Data.List+import DataConstructors+import Doc.PPrint+import E.Annotate(annotateDs,annotateCombs,annotateProgram)+import E.E+import E.Eta+import E.FromHs+import E.Inline+import E.LambdaLift+import E.LetFloat+import E.Lint+import E.Program+import E.Rules+import E.Traverse+import E.TypeAnalysis+import E.TypeCheck+import E.Values+import E.WorkerWrapper+import FrontEnd.Class(augmentClassHierarchy)+import FrontEnd.HsSyn+import FrontEnd.KindInfer+import FrontEnd.Tc.Module+import FrontEnd.Warning+import Grin.Show(render)+import Ho.Build+import Ho.Collected+import Info.Types+import Name.Id+import Name.Name+import Options+import Support.CanType(getType)+import Support.FreeVars+import Support.TempDir+import Support.Transform+import Util.Gen+import Util.Graph+import Util.Progress+import Util.SetLike as S+import qualified E.CPR+import qualified E.Demand as Demand(analyzeProgram)+import qualified E.SSimplify as SS+import qualified FlagDump as FD+import qualified FlagOpts as FO+import qualified Info.Info as Info+import qualified Stats++lamann _ nfo = return nfo+letann e nfo = return (annotateArity e nfo)+idann ps i nfo = return (props ps i nfo) where+    props :: IdMap Properties -> Id -> Info.Info -> Info.Info+    props ps i = case mlookup i ps of+        Just ps ->  modifyProperties (mappend ps)+        Nothing ->  id++processInitialHo ::+    CollectedHo       -- ^ current accumulated ho+    -> Ho             -- ^ new ho, freshly read from file+    -> IO CollectedHo -- ^ final combined ho data.+processInitialHo accumho aho = withStackStatus "processInitialHo" $ do+    let Rules rm = hoRules $ hoBuild aho+        newTVrs = fsts $ hoEs (hoBuild aho)+        (_,orphans) = spartition (\ (k,_) -> k `elem` map tvrIdent newTVrs) rm++    let fakeEntry = emptyComb { combRules = map ruleUpdate . concat $ values orphans }+        combs =  fakeEntry:[combRules_s (map ruleUpdate $ findWithDefault [] (tvrIdent t) rm) (bindComb (t,e))  | (t,e) <- hoEs (hoBuild aho) ]++    -- extract new combinators and processed rules+    let choCombinators' = fromList [ (combIdent c,c) | c <- runIdentity $ annotateCombs (choVarMap accumho) (\_ -> return) letann lamann combs]+        nrules = map ruleUpdate . combRules $ findWithDefault emptyComb emptyId choCombinators'+        reRule :: Comb -> Comb+        reRule comb = combRules_u f comb where+            f rs = Data.List.union  rs [ x | x <- nrules, ruleHead x == combHead comb]++    let choCombs = sfilter (\(k,_) -> k /= emptyId) choCombinators'+    return $ updateChoHo mempty {+        choExternalNames = choExternalNames accumho `mappend` (fromList . map tvrIdent $ newTVrs),+        choCombinators = choCombs `mappend` fmap reRule (choCombinators accumho),+        choHoMap = Map.singleton (hoModuleGroup aho) aho `mappend` choHoMap accumho+        }++processDecls ::+    CollectedHo             -- ^ Collected ho+    -> Ho                   -- ^ preliminary haskell object  data+    -> TiData               -- ^ front end output+    -> IO (CollectedHo,Ho)  -- ^ (new accumulated ho, final ho for this modules)+processDecls cho ho' tiData = withStackStatus "processDecls" $  do+    -- some useful values+    let ho = choHo cho+        -- XXX typechecker drops foreign exports!+        decls  = tiDataDecls tiData ++ [ x | x@HsForeignExport {} <- originalDecls ]+        originalDecls =  concat [ hsModuleDecls  m | (_,m) <- tiDataModules tiData ]++    -- build datatables+    let derives = (collectDeriving originalDecls)+    let dataTable = toDataTable (getConstructorKinds (hoKinds $ hoTcInfo ho'))+            (tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)+        classInstances = deriveClasses (choCombinators cho) fullDataTable derives+        fullDataTable = dataTable `mappend` hoDataTable (hoBuild ho)+    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)+    wdump FD.Derived $ do+        mapM_ print derives+        mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) classInstances+    -- initial program+    let prog = program {+            progDataTable = fullDataTable,+            progExternalNames = choExternalNames cho,+            progModule = head (fsts $ tiDataModules tiData)+            }+    -- Convert Haskell decls to E+    let allAssumps = (tiAllAssumptions tiData `mappend` hoAssumps (hoTcInfo ho))+        theProps = fromList [ (toId x,y) | (x,y) <- Map.toList $ tiProps tiData]+    ds' <- convertDecls tiData theProps+        (hoClassHierarchy $ hoTcInfo ho') allAssumps  fullDataTable decls+    processIOErrors+    let ds = classInstances ++ [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]+    -- Build rules from instances, specializations, and user specified rules and catalysts+    let augmentedClassHierarchy = hoClassHierarchy (hoTcInfo ho) `augmentClassHierarchy` hoClassHierarchy (hoTcInfo ho')+    instanceRules <- createInstanceRules fullDataTable augmentedClassHierarchy (ds `mappend` hoEs (hoBuild ho))+    userRules <- convertRules (progModule prog) tiData (hoClassHierarchy  $ hoTcInfo ho') allAssumps fullDataTable decls+    (nds,specializeRules) <- procAllSpecs fullDataTable (tiCheckedRules tiData) ds++    ds <- return $ ds ++ nds+    wdump FD.CoreInitial $+        mapM_ (\(v,lc) -> printCheckName'' fullDataTable v lc) ds+    ds <- annotateDs mempty (\_ nfo -> return nfo) (\_ nfo -> return nfo) (\_ nfo -> return nfo) ds+    wdump FD.CoreInitial $+        mapM_ (\(v,lc) -> printCheckName'' fullDataTable v lc) ds++    let rules@(Rules rules') = instanceRules `mappend` userRules `mappend` specializeRules++    dumpRules rules++    let seasoning = freeVars [ rs | (k,rs) <- toList rules', k `notMember` defined ] `intersection` defined+        defined = fromList $ map (tvrIdent . fst) ds :: IdSet++    -- our initial program+    prog <- return prog { progSeasoning = seasoning }+    Identity prog <- return $ programMapDs (\ (t,e) -> return (shouldBeExported (getExports $ hoTcInfo ho') t,e)) $ atomizeApps False (programSetDs ds prog)++    -- now we must attach rules to the existing chos, as well as the current ones+    let addRule c = case mlookup (combIdent c) rules' of+            Nothing -> c+            Just rs -> combRules_u (map ruleUpdate . Data.List.union rs) c+    prog <- return $ progCombinators_u (map addRule) prog+    cho <- return $ updateChoHo $ choCombinators_u (fmap addRule) cho++    -- Here we substitute in all the original types, with rules and properties defined in the current module included+    prog <- return $ runIdentity $ annotateProgram (choVarMap cho) (idann theProps) letann lamann prog++    lintCheckProgram (putErrLn "LintPostProcess") prog++    let entryPoints = fromList . execWriter $ programMapDs_ (\ (t,_) -> when+            (getProperty prop_EXPORTED t || getProperty prop_INSTANCE t || getProperty prop_SPECIALIZATION t)  (tell [tvrIdent t])) prog+    prog <- return $ prog { progEntry = entryPoints `mappend` progSeasoning prog }++    lintCheckProgram (putErrLn "InitialLint") prog++    prog <- programPrune prog++    -- initial pass, performs+    -- eta expansion of definitons+    -- simplify+    -- type analysis+    -- floating outward+    -- simplify+    -- floating inward++    let sopt = SS.cacheSimpOpts SS.emptySimplifyOpts {+            SS.so_boundVars = choCombinators cho,+            SS.so_forwardVars = progSeasoning prog+            }+    let tparms = transformParms {+            transformPass = "PreInit",+            transformDumpProgress = verbose+            }++    -- quick float inward pass to inline once used functions and prune unused ones+    prog <- transformProgram tparms {+        transformCategory = "FloatInward",+        transformOperation = programFloatInward+        } prog++    putProgress "<"+    pr_r <- progressIONew (length $ programDecomposedDs prog) 25 '.'++    let fint mprog = do+        let names = pprint [ n | (n,_) <- programDs mprog]+        withStackStatus ("fint: " ++ names) $ do+        when coreMini $ putErrLn ("----\n" ++ names)+        let tparms = transformParms { transformPass = "Init", transformDumpProgress = coreMini }++        lintCheckProgram onerrNone mprog+        mprog <- evaluate $ etaAnnotateProgram mprog+        lintCheckProgram onerrNone mprog++        mprog <- simplifyProgram sopt "Init-One" coreMini mprog++        -- | this catches more static arguments if we wait until after the initial normalizing simplification pass+        mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "SimpleRecursive"+                                         , transformOperation = return . staticArgumentTransform } mprog++        mprog <- transformProgram tparms { transformCategory = "FloatOutward", transformOperation = floatOutward } mprog+        mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformPass = "PreInit"+                                         , transformOperation = typeAnalyze True } mprog++        mprog <- transformProgram tparms { transformCategory = "FloatOutward", transformOperation = floatOutward } mprog++        -- perform another supersimplify in order to substitute the once used+        -- variables back in and replace the variable of case of variables with+        -- the default binding of the case statement.+        mprog <- simplifyProgram sopt "Init-Two-FloatOutCleanup" coreMini mprog+        mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformOperation = typeAnalyze True } mprog++        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog+        mprog <- Demand.analyzeProgram mprog+        lintCheckProgram onerrNone mprog+        mprog <- simplifyProgram sopt "Init-Three-AfterDemand" False mprog+        when miniCorePass $ printProgram mprog -- mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) (programDs mprog)+        when miniCoreSteps $ Stats.printLStat (optStatLevel options) ("InitialOptimize:" ++ names) (progStats mprog)+        wdump FD.Progress $ let SubProgram isRec = progType mprog in  progressIOSteps pr_r (if isRec then "*" else ".")+        return mprog+    lintCheckProgram onerrNone prog+    prog <- programMapProgGroups mempty fint prog++    wdump FD.Stats $+        Stats.printLStat (optStatLevel options) "Initial Pass Stats" (progStats prog)+    lintCheckProgram onerrNone prog++    prog <- etaExpandProg "Init-Big-One" prog { progStats = mempty }+    prog <- transformProgram tparms {+        transformPass = "Init-Big-One",+        transformCategory = "FloatInward",+        transformOperation = programFloatInward+        } prog++    prog <- Demand.analyzeProgram prog+    prog <- simplifyProgram' sopt "Init-Big-One" verbose (IterateMax 4) prog++    wdump FD.Stats $+        Stats.printLStat (optStatLevel options) "Init-Big-One Stats" (progStats prog)++    pr_r <- progressIONew (length $ programDecomposedCombs prog) 25 '.'++    -- This is the main function that optimizes the routines before writing them out+    let optWW mprog = do+        let names = pprint [ n | (n,_) <- programDs mprog]+        liftIO $ when coreMini $ putErrLn ("----\n" ++ names)+        smap <- get+        let tparms = transformParms { transformPass = "OptWW", transformDumpProgress = coreMini }+            sopt = SS.cacheSimpOpts SS.emptySimplifyOpts {+                SS.so_boundVars = smap,+                SS.so_forwardVars = progSeasoning mprog+                }++        mprog <- simplifyProgram sopt "Simplify-One" coreMini mprog+        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog+        mprog <- Demand.analyzeProgram mprog+        mprog <- simplifyProgram sopt "Simplify-Two" coreMini mprog+        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog+        mprog <- Demand.analyzeProgram mprog+        mprog <- return $ E.CPR.cprAnalyzeProgram mprog+        mprog' <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "WorkWrap", transformOperation = return . workWrapProgram } mprog+        let wws = length (programDs mprog') - length (programDs mprog)+--        liftIO $ wdump FD.Progress $ putErr (replicate wws 'w')+        mprog <- return mprog'++        mprog <- simplifyProgram sopt "Simplify-Three" coreMini mprog++        --mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog+        --mprog <- Demand.analyzeProgram mprog+        --mprog <- return $ E.CPR.cprAnalyzeProgram mprog+        --mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "WorkWrap2", transformOperation = return . workWrapProgram } mprog+        --mprog <- simplifyProgram sopt "Simplify-Four" coreMini mprog++        -- annotate our bindings for further passes+        mprog <- return $ etaAnnotateProgram mprog+        mprog <- Demand.analyzeProgram mprog+        mprog <- return $ E.CPR.cprAnalyzeProgram mprog++        put $ fromList [ (combIdent c,c) | c <- progCombinators mprog] `S.union` smap++        --liftIO $ wdump FD.Progress $ let SubProgram rec = progType mprog in  putErr (if rec then "*" else ".")+        liftIO $ wdump FD.Progress $ let SubProgram isRec = progType mprog in  progressIOSteps pr_r (if wws > 0 then "w" else if isRec then "*" else ".")+        return mprog++    prog <- evalStateT (programMapProgGroups mempty optWW prog { progStats = mempty }) (SS.so_boundVars sopt)+    putProgressLn ">"+    wdump FD.Stats $+        Stats.printLStat (optStatLevel options) "MainPass Stats" (progStats prog)++    processIOErrors++    lintCheckProgram (putErrLn "After the workwrap/CPR") prog++    prog <- programPrune prog++    lintCheckProgram (putErrLn "After the Opimization") prog+    wdump FD.Core $ printProgram prog++    let newHoBuild = (hoBuild ho') {+        hoDataTable = dataTable,+        hoEs = programDs prog,+        hoRules = hoRules (hoBuild ho') `mappend` rules+        }+        newMap = fmap (\c -> Just (EVar $ combHead c)) $ progCombMap prog+    return (updateChoHo $ mempty {+        choHoMap = Map.singleton (hoModuleGroup ho') ho' { hoBuild = newHoBuild},+        choCombinators = fromList $ [ (combIdent c,c) | c <- progCombinators prog ],+        choExternalNames = idMapToIdSet newMap+        } `mappend` cho,ho' { hoBuild = newHoBuild })++coreMini = dump FD.CoreMini+corePass = dump FD.CorePass+coreSteps = dump FD.CoreSteps+miniCorePass = coreMini && corePass+miniCoreSteps = coreMini && coreSteps++dumpRules rules = do+    wdump FD.Rules $ putStrLn "  ---- user rules ---- " >> printRules RuleUser rules+    wdump FD.Rules $ putStrLn "  ---- user catalysts ---- " >> printRules RuleCatalyst rules+    wdump FD.RulesSpec $ putStrLn "  ---- specializations ---- " >> printRules RuleSpecialization rules++programPruneUnreachable :: Program -> Program+programPruneUnreachable prog = progCombinators_s ds' prog where+    ds' = reachableFrom combIdent freeVars (progCombinators prog) (toList $ progEntry prog)++programPrune :: Program -> IO Program+programPrune prog = transformProgram transformParms { transformCategory = "PruneUnreachable"+                                                    , transformDumpProgress  = miniCorePass+                                                    , transformOperation = evaluate . programPruneUnreachable } prog++etaExpandProg :: String -> Program -> IO Program+etaExpandProg pass prog = do+    let f prog = prog' { progStats = progStats prog `mappend` stats } where+        (prog',stats) = Stats.runStatM $  etaExpandProgram prog+    transformProgram transformParms { transformPass = pass, transformCategory = "EtaExpansion"+                                    , transformDumpProgress = miniCorePass,  transformOperation = evaluate . f } prog++getExports ho =  Set.fromList $ map toId $ concat $  Map.elems (hoExports ho)+shouldBeExported exports tvr+    | tvrIdent tvr `Set.member` exports || getProperty prop_SRCLOC_ANNOTATE_FUN tvr  = setProperty prop_EXPORTED tvr+    | otherwise = tvr++transTypeAnalyze = transformParms { transformCategory = "typeAnalyze",  transformOperation = typeAnalyze True }++simplifyProgram sopt name dodump prog = liftIO $ do+    let istat = progStats prog+    let g prog = do+            let nprog = SS.programPruneOccurance prog+            when (corePass && dodump) $ do+                putStrLn "-- After Occurance Analysis"+                printProgram nprog+            lintCheckProgram (putErrLn "AfterOccurance") nprog+            return $ SS.programSSimplify sopt nprog+    prog <- transformProgram transformParms { transformCategory = "Simplify"+                                            , transformPass = name+                                            , transformIterate = IterateDone+                                            , transformDumpProgress = dodump+                                            , transformOperation = g } prog { progStats = mempty }+    when (dodump && (dump FD.Progress || coreSteps)) $+        Stats.printLStat (optStatLevel options) ("Total: " ++ name) (progStats prog)+    return prog { progStats = progStats prog `mappend` istat }++{-+simplifyProgramPStat sopt name dodump prog = do+    let istat = progStats prog+    let g =  SS.programSSimplifyPStat sopt { SS.so_dataTable = progDataTable prog } . SS.programPruneOccurance+    prog <- transformProgram ("PS:" ++ name) IterateDone dodump g prog  { progStats = mempty }+    when ((dodump && dump FD.Progress) || dump FD.CoreSteps) $ Stats.printStat ("Total: " ++ name) (progStats prog)+    return prog { progStats = progStats prog `mappend` istat }+-}+simplifyProgram' sopt name dodump iterate prog = do+    let istat = progStats prog+    let g =  return . SS.programSSimplify sopt . SS.programPruneOccurance+    prog <- transformProgram transformParms { transformCategory = "Simplify"+                                            , transformPass = name+                                            , transformIterate = iterate+                                            , transformDumpProgress = dodump+                                            , transformOperation = g } prog { progStats = mempty }+    when (dodump && (dump FD.Progress || coreSteps)) $ Stats.printLStat (optStatLevel options) ("Total: " ++ name) (progStats prog)+    return prog { progStats = progStats prog `mappend` istat }++{-# NOINLINE compileWholeProgram #-}+compileWholeProgram prog = do+    performGC++    when verbose $ do+        Stats.print "PassStats" Stats.theStats+        Stats.clear Stats.theStats++    esmap <- programEsMap prog+    let mainFunc = parseName Val (maybe "Main.main" snd (optMainFunc options))+        dataTable = progDataTable prog+        ffiExportNames = [ tv | tv <- map combHead $ progCombinators prog, name <- tvrName tv, "FE@" `isPrefixOf` show name ]+    (main,mainv) <- getMainFunction dataTable mainFunc esmap+    prog <- return $ programUpdate prog {+        progMain   = tvrIdent main,+        progEntry = fromList $ map tvrIdent (main:ffiExportNames),+        progCombinators = emptyComb { combHead = main, combBody = mainv }:map (unsetProperty prop_EXPORTED) (progCombinators prog)+        }+    prog <- transformProgram transformParms {+        transformCategory = "PruneUnreachable",+        transformOperation = evaluate . programPruneUnreachable+        } prog++    prog <- if (fopts FO.TypeAnalysis) then do+      transformProgram transformParms { transformCategory = "TypeAnalyzeMethods",+                                        transformOperation = typeAnalyze False,+                                        transformDumpProgress = dump FD.Progress }+                       prog+            else return prog++    when verbose $ do+        putStrLn "Type analyzed methods"+        flip mapM_ (sortUnder (show . fst) (programDs prog)) $ \ (t,e) -> do+        let (_,ts) = fromLam e+            ts' = takeWhile (sortKindLike . getType) ts+        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" +++            concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]+    lintCheckProgram onerrNone prog+    prog <- programPrune prog++    cmethods <- do+        let es' = concatMap expandPlaceholder (progCombinators prog)+        es' <- return [ combBody_u floatInward e |  e <- es' ]+        wdump FD.Class $ do+            sequence_ [ printCheckName'' dataTable (combHead x) (combBody x) |  x <- es']+        return es'++    prog <- evaluate $ progCombinators_s ([ p | p <- progCombinators prog,+        combHead p `notElem` map combHead cmethods] ++ cmethods) prog+    prog <- annotateProgram mempty (\_ nfo -> return $ unsetProperty prop_INSTANCE nfo)+        letann (\_ nfo -> return nfo) prog++    if not (fopts FO.GlobalOptimize) then do+        prog <- programPrune prog+        wdump FD.CoreBeforelift $ printProgram prog+        prog <- transformProgram transformParms {+            transformCategory = "LambdaLift",+            transformDumpProgress = dump FD.Progress,+            transformOperation = lambdaLift } prog+        wdump FD.CoreAfterlift $ printProgram prog+        prog <- return $ atomizeApps True prog+        wdump FD.CoreMangled $ dumpCore "mangled" prog+        return prog+     else do+    prog <- transformProgram transTypeAnalyze {+        transformPass = "Main-AfterMethod",+        transformDumpProgress = verbose } prog+    prog <- simplifyProgram SS.emptySimplifyOpts "Main-One" verbose prog+    prog <- etaExpandProg "Main-AfterOne" prog+    wdump FD.CorePass $ dumpCore "before-TypeAnalyze-Main-AfterSimp" prog+    prog <- transformProgram transTypeAnalyze {+        transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog+    prog <- simplifyProgram SS.emptySimplifyOpts "Main-Two" verbose prog++    -- run optimization again with no rules enabled+    prog <- return $ runIdentity $ annotateProgram mempty (\_ nfo -> return $+        modifyProperties (flip (foldr S.delete) [prop_HASRULE,prop_WORKER]) nfo)+        letann (\_ -> return) prog+    --prog <- transformProgram "float inward" DontIterate True programFloatInward prog++    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True }+        "SuperSimplify no rules" verbose prog++    -- We should float inward right before lambda lifting so that when a case statement is lifted out, it takes any local definitions with it.+--    prog <- transformProgram transformParms {+--        transformCategory = "FloatInward",+--        transformDumpProgress = dump FD.Progress,+--        transformOperation = programFloatInward+--        } prog+    -- perform lambda lifting+--    prog <- denewtypeProgram prog++    prog <- transformProgram transformParms {+        transformCategory = "BoxifyProgram",+        transformDumpProgress = dump FD.Progress,+        transformOperation = boxifyProgram } prog+    prog <- programPrune prog++    prog <- Demand.analyzeProgram prog+    prog <- return $ E.CPR.cprAnalyzeProgram prog+    prog <- transformProgram transformParms {+        transformCategory = "Boxy WorkWrap",+        transformDumpProgress = dump FD.Progress,+        transformOperation = evaluate . workWrapProgram } prog+    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True }+        "SuperSimplify after Boxy WorkWrap" verbose prog+    prog <- return $ runIdentity $ programMapBodies (return . cleanupE) prog++    wdump FD.CoreBeforelift $ dumpCore "before-lift" prog+    prog <- transformProgram transformParms {+        transformCategory = "LambdaLift",+        transformDumpProgress = dump FD.Progress,+        transformOperation = lambdaLift } prog++    wdump FD.CoreAfterlift $ dumpCore "after-lift" prog++    finalStats <- Stats.new++    -- final optimization pass to clean up lambda lifting droppings+--    prog <- flip programMapBodies prog $ \ e -> do+--        let cm stats e = do+--            let sopt = mempty {  SS.so_dataTable = dataTable }+--            let (stat, e') = SS.simplifyE sopt e+--            Stats.tickStat stats stat+--            return e'+--        doopt (mangle' Nothing dataTable) False finalStats "PostLambdaLift"  cm e+--    wdump FD.Progress $ Stats.print "PostLifting" finalStats++    lintCheckProgram (putErrLn "LintPostLifting") prog++--    wdump FD.Progress $ printEStats (programE prog)++    prog <- Demand.analyzeProgram prog+    prog <- return $ E.CPR.cprAnalyzeProgram prog+    prog <- simplifyProgram SS.emptySimplifyOpts {+        SS.so_postLift = True, SS.so_finalPhase = True } "PostLiftSimplify" verbose prog+--    prog <- programFloatInward prog++    when verbose $ do+        Stats.print "PassStats" Stats.theStats+        Stats.clear Stats.theStats++    prog <- return $ atomizeApps True prog+    wdump FD.CoreMangled $ dumpCore "mangled" prog+    return prog++-- | this gets rid of all type variables, replacing them with boxes that can hold any type.+-- The program is still type-safe, but all polymorphism has been removed in favor of+-- implicit coercion to a universal type in preparation for the grin transformation.++boxifyProgram :: Program -> IO Program+boxifyProgram prog = ans where+    ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog)+    f (t,e) = do+        e <- return $ runReader (g e) Set.empty+        tt <- return $ runReader (boxify (tvrType t)) Set.empty+        return (t {tvrType = tt},e)+    _tv t = t { tvrType = boxify (tvrType t) }+    g e = do+        emapEG g (boxify) e -- (\e -> do putStrLn ("box: " ++ pprint e) ; return $ boxify e) e+--    boxify t | Just e <- followAlias (progDataTable prog) t = boxify e+    boxify (from_unsafeCoerce -> Just (e,t)) = do+        t' <- boxify t+        e' <- boxify e+        case typesCompatable t' (getType e') of+            Just () -> return e+            _ -> return $ prim_unsafeCoerce e' t'+    boxify (EPi t e) = local (Set.insert (tvrIdent t)) $ do+        nt <- boxify $ tvrType t+        ne <- boxify e+        return $ EPi t { tvrType = nt } ne+    boxify v@(EVar vr) | canBeBox v = do+        s <- ask+        if tvrIdent vr `Set.member` s then return v else return $ mktBox (tvrType vr)+    boxify (ELit lc) = do+        na <- mapM boxify (litArgs lc)+        return $ ELit lc { litArgs = na }+--    boxify v@(EAp _ _) | canBeBox v = mktBox (getType v)+--    boxify (EAp (ELam t b) e) = boxify (subst t e b)+ --   boxify (EAp a b) = EAp (boxify a) b -- TODO there should be no applications at the type level by now (boxify b)+    boxify (EAp a b) = liftM2 eAp (boxify a) (boxify b)+    boxify s@ESort {} = return s+    boxify x = error $ "boxify: " ++ show x++-- | get rid of unused bindings+cleanupE :: E -> E+cleanupE e = runIdentity (f e) where+    f (ELam t@TVr { tvrIdent = v } e) | v /= emptyId, v `notMember` freeIds e = f (ELam t { tvrIdent = emptyId } e)+    f (EPi t@TVr { tvrIdent = v } e) | v /= emptyId, v `notMember` freeIds e = f (EPi t { tvrIdent = emptyId } e)+    f ec@ECase { eCaseBind = t@TVr { tvrIdent = v } } | v /= emptyId, v `notMember` (freeVars (caseBodies ec)::IdSet) = f ec { eCaseBind = t { tvrIdent = emptyId } }+    f e = emapEG f f e
+ src/E/PrimDecode.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE OverloadedStrings #-}+-- translate foreign Prim statements to jhc core+module E.PrimDecode(processPrim) where++import Text.Printf++import C.Prims+import Cmm.Op(readTy,Ty)+import Data.Maybe+import DataConstructors+import E.E+import E.Values+import FrontEnd.SrcLoc+import FrontEnd.Tc.Kind+import FrontEnd.Warning+import Name.Name+import Name.Names+import PackedString+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Gen+import qualified Cmm.Op as Op+import qualified Data.Map as Map++data Typ = [BType] :-> BType+    deriving (Show)++data BType+    = BKind KBase+    | BTup [BType]+    | BState++instance Show BType where+    showsPrec n (BKind k) = showsPrec n k+    showsPrec _ BState = showString "State#"+    showsPrec n (BTup ts) = showsPrec n ts++star = [] :-> BKind Star+hash = [] :-> BKind KHash+starHash = [] :-> BKind KQuestQuest+state = [] :-> BState+utup ~([] :-> t1) ~([] :-> t2) = [] :-> BTup [t1,t2]+utup1 ~([] :-> t1) = [] :-> BTup [t1]+array = hash+bang = hash++infixr 3 +>+(+>) :: Typ -> Typ -> Typ+~([] :-> k) +> ks :-> rt = (k:ks) :-> rt++infix 1 ==>+a ==> b = (a,b)+--plainPrimMap, rawArgPrimMap, prefixPrimMap :: Map.Map Atom Typ+plainPrimMap :: Map.Map Atom Typ+plainPrimMap = Map.fromList+    [ "seq"            ==> star +> starHash +> starHash+    , "dependingOn"    ==> star +> starHash +> star+    , "newWorld__"     ==> star +> state+    , "unsafeCoerce"   ==> star +> star+    , "options_target" ==> hash+    , "touch_"         ==> starHash +> state +> state+    , "zero"           ==> starHash+    , "one"            ==> starHash+    , "box"            ==> hash +> star+    , "unbox"          ==> star +> hash+    , "exitFailure__"  ==> hash +> hash+    , "constPeekByte"  ==> hash +> hash+    -- array operations+    , "newArray__"     ==> hash +> star +> state +> utup state array+    , "newBlankArray__"==> hash +> state +> utup state array+    , "copyArray__"    ==> hash +> hash +> hash +> array +> array +> state +> state+    , "readArray__"    ==> array +> hash +> state +> utup state star+    , "writeArray__"   ==> array +> hash +> star +> state +> state+    , "indexArray__"   ==> array +> hash +> utup1 star+    -- accessing the rts directly+    , "toBang_"        ==> star +> bang+    , "fromBang_"      ==> bang +> star+    , "isWHNF"         ==> star +> hash+    , "isInHeap"       ==> bang +> hash+    , "bangPtr"        ==> bang +> hash+    , "bangBits"       ==> bang +> hash+    ] `Map.union` fmap (const (starHash +> starHash)) incDec+      `Map.union` fmap (const star) primBoundMap++primBoundMap = Map.fromList [("maxBound",PrimMaxBound),+                             ("minBound",PrimMinBound),+                             ("umaxBound",PrimUMaxBound)]+incDec = Map.fromList [("increment",Op.Add),("decrement",Op.Sub),+                       ("fincrement",Op.FAdd),("fdecrement",Op.FSub)]++ashow op = toAtom (show op)+binOpMap = Map.fromList [ ashow op ==> (op, starHash +> starHash +> starHash)+        | op :: Op.BinOp <- [minBound .. maxBound] ]+unOpMap = Map.fromList [ ashow op ==> (op,starHash +> starHash)+    | op :: Op.UnOp <- [minBound .. maxBound] ]+convOpMap = Map.fromList [ ashow op ==> (op,starHash +> starHash)+    | op :: Op.ConvOp <- [minBound .. maxBound] ]++-- | A safe version of 'zipWith'.+pairWith  :: (a -> b -> c)+          -> [a] -> [b] -> Maybe [c]+pairWith f xs ys = g xs ys [] where+    g [] [] rs = Just $ reverse rs+    g (x:xs) (y:ys) rs = g xs ys (f x y:rs)+    g _ _ _ = Nothing++ePrim prim as t = EPrim prim as t++processPrim :: MonadWarn m+    => DataTable+    -> SrcLoc     -- ^ location of declaration+    -> Atom       -- ^ primitive name+    -> [E]        -- ^ arguments+    -> E          -- ^ return type+    -> Requires   -- ^ c requires+    -> m E        -- ^ result+processPrim dataTable srcLoc pName args rType req = ans where+    passThrough = EPrim (PrimPrim pName) args rType+    ans = checkOp binOpMap doBinOp $ checkOp unOpMap (doUnOp Op.UnOp) $+        checkOp convOpMap (doUnOp Op.ConvOp) primCheckOther+    checkOp table yesMatch noMatch = case Map.lookup pName table of+        Just (op,ty) -> checkType ty (return passThrough) (yesMatch op)+        Nothing -> noMatch+    primCheckOther = case Map.lookup pName plainPrimMap of+        Just ty -> checkType ty (return passThrough) (primOther pName args)+        Nothing -> primPrefix (show pName) args+      where primOther "box" [a] = return ans where+                Just (ExtTypeBoxed cna _ _) = lookupExtTypeInfo dataTable rType+                ans = ELit litCons { litName = cna, litArgs = [a], litType = rType }+            primOther "unbox" [a] = return ans where+                (vara:_) = newIds (freeVars (a,rType))+                ans = unbox dataTable a vara $ \tvra -> EVar tvra+            primOther "seq" [a,b] = return $ prim_seq a b+            primOther "exitFailure__" [_] = return $ EError "" rType+            primOther "options_target" _ = return (ELit (LitInt 0 rType))+            primOther "constPeekByte" [a] = return $ ePrim (Peek Op.bits8) [a] rType+            primOther op [a] | Just x <- Map.lookup op incDec = do+                (pa,(ta,sta)) <- extractPrimitive dataTable a+                Just ret <- return $ boxResult dataTable rType $ \tr str ->+                    ePrim (Op (Op.BinOp x (stringToOpTy ta) (stringToOpTy ta)) tr)+                        [pa, ELit (LitInt 1 sta)] str+                return ret+            primOther op [] | Just x <- Map.lookup op primBoundMap = do+                Just res <- return $ boxResult dataTable rType $ \tr str ->+                    ePrim (PrimTypeInfo tr tr x) [] str+                return res+            primOther op [] | Just x <- lookup op ["zero" ==> 0,"one" ==> 1] = do+                Just res <- return $ boxResult dataTable rType $ \tr str ->+                    ELit (LitInt x str)+                return res+            -- since the primitive was found in the plainPrimMap file and+            -- typechecked we pass it through unchanged.+            primOther _ _ = return passThrough+    preType n s = getPrefix n s >>= Op.readTy+    checkType' ty os = checkType ty (return passThrough) os+    primPrefix (preType "peek." -> Just c) ~[a,w] = checkType'+        (hash +> state +> utup state hash) $ return+            (ePrim (Peek c) [w,a] rType)+    primPrefix (preType "poke." -> Just c) ~[a,v,w] = checkType'+        (hash +> hash +> state +> state) $ return+           (ePrim (Poke c) [w,a,v] rType)+    primPrefix (preType "sizeOf." -> Just c) _ = primInfo c Op.bits32 PrimSizeOf+    primPrefix (preType "alignmentOf." -> Just c) _ = primInfo c Op.bits32 PrimAlignmentOf+    primPrefix (preType "maxBound." -> Just c) _ = primInfo c c PrimMaxBound+    primPrefix (preType "minBound." -> Just c) _ = primInfo c c PrimMinBound+    primPrefix (preType "umaxBound." -> Just c) _ = primInfo c c PrimUMaxBound+    primPrefix (getPrefix "options_" -> Just c) _ =+        return (ePrim (CConst req (packString $ "JHC_" ++ c)) [] rType)+    primPrefix (getPrefix "const." -> Just c) _ = checkType' star $ do+        Just ret <- return $ boxResult dataTable rType $ \tr str ->+            ePrim (CConst req $ packString c) [] str+        return ret+    primPrefix (getPrefix "error." -> Just c) _ = return (EError c rType)+    primPrefix _ _ = primUnknown+    primInfo c cr wh = checkType' (hash +> hash) $ return+       (ePrim (PrimTypeInfo c cr wh) [] rType)+    primUnknown = do+        warn srcLoc (PrimitiveUnknown pName) $+                    printf "Unknown primitive '%s'" (fromAtom pName :: String)+        return passThrough+    doBinOp op = do+        let [a,b] = args+        (pa,(ta,_)) <- extractPrimitive dataTable a+        (pb,(tb,_)) <- extractPrimitive dataTable b+        Just res <- return $ boxResult dataTable rType $ \tr str ->+                 ePrim Op { primCOp = Op.BinOp op (stot op 1 ta) (stot op 2 tb), primRetTy = tr } [pa, pb] str+        return res+    doUnOp bOp op = do+        let [a] = args+        (pa,(ta,_)) <- extractPrimitive dataTable a+        Just res <- return $ boxResult dataTable rType $ \tr str ->+                 ePrim Op { primCOp = bOp op (stot op 1 ta), primRetTy = tr } [pa] str+        return res++    checkType (tas :-> trt) onFail onPass =+        case pairWith match tas (map getType args) of+            Just cs | and cs, match trt rType -> onPass+            _ -> do+                warn srcLoc PrimitiveBadType $+                    printf "Primitive type mismatch. expected '%s' but found '%s -> %s'"+                        (show (tas :-> trt)) (show $ map (getType . getType) args) (show $ getType rType)+                onFail++match k e = g k where+    t = getType e+    g BState = isState_ e+    g (BTup ks) = case e of+        ELit (LitCons { litName = n, litArgs = as }) ->+            n == unboxedNameTuple TypeConstructor (length as) && matches ks as+        _ -> False+    g (BKind k) = f k+    -- check the kind+    f Star = t == eStar+    f KHash = t == eHash+    f KQuestQuest = t == eStar || t == eHash+    f _  = False++matches ks es = maybe False and $ pairWith match ks es++type T = E++boxResult :: DataTable -> T -> (Ty -> T -> E) -> Maybe E+boxResult dataTable t fn = mdo+        (res,(ta,sta)) <- boxPrimitive dataTable (fn (stringToOpTy ta) sta) t+	return res++stringToOpTy :: ExtType -> Ty+stringToOpTy s = stringToOpTy' "" s++stringToOpTy' :: String -> ExtType -> Ty+stringToOpTy' x (show -> s) = case readTy s of+    Just t -> t+    _ -> error $ printf "stringToOpTy(%s): '%s'" x s++stot :: Show a => a -> Int -> ExtType -> Ty+stot op n s = stringToOpTy' (show op ++ show n) s++unbox :: DataTable -> E -> Id -> (TVr -> E) -> E+unbox dataTable e vn wtd = eCase e  [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd tvra)] Unknown where+    te = getType e+    tvra = tVr vn sta+    (ExtTypeBoxed cna sta _) = fromMaybe (error $ "lookupExtTypeInfo(unbox): " ++ show te) $ lookupExtTypeInfo dataTable te
+ src/E/PrimOpt.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DoRec,ViewPatterns #-}+module E.PrimOpt(performPrimOpt) where++import Control.Monad.Fix()++import C.Prims+import Cmm.OpEval+import Doc.DocLike+import Doc.PPrint+import E.E+import E.Values+import Stats+import StringTable.Atom+import Support.CanType+import qualified Cmm.Op as Op++{-@Extensions++# Foreign Primitives++In addition to foreign imports of external functions as described in the FFI+spec. Jhc supports 'primitive' imports that let you communicate primitives+directly to the compiler. In general, these should not be used other than in the+implementation of the standard libraries. They generally do little error+checking as it is assumed you know what you are doing if you use them. All+haskell visible entities are introduced via foreign declarations in jhc.++They all have the form++    foreign import primitive "specification" haskell_name :: type++where "specification" is one of the following++seq+: evaluate first argument to WHNF, then return the second argument++zero,one+: the values zero and one of any primitive type.++const.C_CONSTANT+: the text following const is directly inserted into the resulting C file++peek.TYPE+: the peek primitive for raw value TYPE++poke.TYPE+: the poke primitive for raw value TYPE++sizeOf.TYPE, alignmentOf.TYPE, minBound.TYPE, maxBound.TYPE, umaxBound.TYPE+: various properties of a given internal type.++error.MESSAGE+: results in an error with constant message MESSAGE.++constPeekByte+: peek of a constant value specialized to bytes, used internally by Jhc.String++box+: take an unboxed value and box it, the shape of the box is determined by the type at which this is imported++unbox+: take an boxed value and unbox it, the shape of the box is determined by the type at which this is imported++increment, decrement+: increment or decrement a numerical integral primitive value++fincrement, fdecrement+: increment or decrement a numerical floating point primitive value++exitFailure__+: abort the program immediately++C-- Primitive+: any C-- primitive may be imported in this manner.++-}++-- | this creates a string representing the type of primitive optimization was+-- performed for bookkeeping purposes++primConv cop t1 t2 e rt = EPrim (Op (Op.ConvOp cop t1) t2) [e] rt++performPrimOpt (ELit lc@LitCons { litArgs = xs }) = do+    xs' <- mapM performPrimOpt xs+    primOpt' (ELit lc { litArgs = xs' })+performPrimOpt (EPrim ap xs t) = do+    xs' <- mapM performPrimOpt xs+    primOpt' (EPrim ap xs' t)+performPrimOpt e = return e++primOpt' e@(EPrim s xs t) = do+    let primopt (Op (Op.BinOp bop t1 t2) tr) [e1,e2] rt =+            binOp bop t1 t2 tr e1 e2 rt+        primopt (Op (Op.ConvOp cop t1) t2) [ELit (LitInt n t)] rt =+            return $ ELit (LitInt (convNumber cop t1 t2 n) rt)+        primopt (Op (Op.ConvOp cop t1) t2) [e1] rt = case convOp cop t1 t2 of+            Nothing | getType e1 == rt -> return e1+            Just cop' | cop' /= cop -> return $ primConv cop' t1 t2 e1 rt+            _ -> fail "couldn't apply conversion optimization"+        primopt (Op (Op.UnOp bop t1) tr) [e1] rt = unOp bop t1 tr e1 rt+        primopt _ _ _ = fail "No Primitive optimization to apply"+    case primopt s xs t of+        Just n -> do+            mtick (toAtom $ "E.PrimOpt." ++ braces (pprint s) ++ cextra s xs )+            primOpt' n+        Nothing -> return e+primOpt' e = return e++cextra Op {} [] = ""+cextra Op {} xs = '.':map f xs where+    f ELit {} = 'c'+    f EPrim {} = 'p'+    f _ = 'e'+cextra _ _ = ""++instance Expression E E where+    toBool True = ELit lTruezh+    toBool False = ELit lFalsezh+    toConstant (ELit (LitInt n t)) = return (n,t)+    toConstant _ = Nothing+    equalsExpression e1 e2 = e1 == e2+    caseEquals scrut (n,t) e1 e2 = eCase scrut [Alt (LitInt n t) e1 ] e2+    toExpression n t = (ELit (LitInt n t))+    createBinOp bop t1 t2 tr e1 e2 str =+                EPrim Op { primCOp = Op.BinOp bop t1 t2,+                                  primRetTy = tr } [e1, e2] str+    createUnOp bop t1 tr e1 str =+                EPrim Op { primCOp = Op.UnOp bop t1,+                                  primRetTy = tr } [e1] str+    fromBinOp (EPrim Op { primCOp = Op.BinOp bop t1 t2,+                                 primRetTy = tr } [e1, e2] str) =+                                     Just (bop,t1,t2,tr,e1,e2,str)+    fromBinOp _ = Nothing+    fromUnOp (EPrim Op {+        primCOp = Op.UnOp bop t1,+        primRetTy = tr } [e1] str) = Just (bop,t1,tr,e1,str)+    fromUnOp _ = Nothing
+ src/E/Program.hs view
@@ -0,0 +1,140 @@+module E.Program where++import Control.Monad.Identity+import Data.Monoid+import Data.List+import Data.Maybe+import qualified Data.Map as Map++import DataConstructors+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.E+import E.Show+import E.TypeCheck+import Name.Id+import Name.Name+import Options+import System.IO+import Util.ContextMonad+import Util.SetLike+import qualified FlagDump as FD+import qualified Stats++data ProgramType = SubProgram Bool | MainProgram | MainComponent++data Program = Program {+    progExternalNames :: IdSet,+    progCombinators   :: [Comb],+    progDataTable     :: DataTable,+    progEntry         :: IdSet,+    progMain          :: Id,+    progModule        :: Module,+    progPasses        :: [String],    -- ^ record of passes the program goes through+    progUsedIds       :: IdSet,       -- ^ filled in by occurance info collection+    progFreeIds       :: IdSet,       -- ^ filled in by occurance info collection+    progSeasoning     :: IdSet,       -- ^ these ids are depended on by external names via RULES+    progType          :: ProgramType,+    progCombMap       :: IdMap Comb,  -- progCombMap is always (fromList . progCombinators)+    progStats         :: !Stats.Stat+    }++program = Program {+    progExternalNames = mempty,+    progCombinators   = mempty,+    progDataTable     = mempty,+    progEntry         = mempty,+    progMain          = emptyId,+    progModule        = mainModule,+    progPasses        = [],+    progUsedIds       = mempty,+    progFreeIds       = mempty,+    progSeasoning     = mempty,+    progType          = MainProgram,+    progCombMap       = mempty,+    progStats         = mempty+    }++progEntryPoints prog = map combHead $ concatMap (progComb prog) (toList $ progEntry prog)+progMainEntry prog = combHead . runIdentity $ progComb prog (progMain prog)++progComb :: Monad m => Program -> Id -> m Comb+progComb prog x = case x `mlookup`  progCombMap prog of+    Nothing -> fail $ "progComb: can't find '" ++ show (tvrShowName tvr { tvrIdent = x }) ++  "'"+    Just c -> return c++programDs :: Program -> [(TVr,E)]+programDs prog = [ (t,e)  | Comb { combHead = t,+                                   combBody = e } <- progCombinators prog]++progCombinators_u f prog =+    programUpdate prog { progCombinators = f $ progCombinators prog }+progCombinators_s cs prog = programUpdate prog { progCombinators = cs }++programUpdate ::  Program -> Program+programUpdate prog = ucache prog where+    ucache prog = prog { progCombMap =+        fromList [ (combIdent c,c) | c <- progCombinators prog ] }++programSetDs' :: [(TVr,E)] -> Program -> Program+programSetDs' ds prog = progCombinators_s newDs prog where+    newDs = [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- ds ]+    lupRules t = case mlookup t (progCombMap prog) of+        Just c -> combRules c+        Nothing -> mempty++programSetDs :: [(TVr,E)] -> Program -> Program+programSetDs ds prog = progCombinators_s [ bindComb (t,e) | (t,e) <- ds ] prog++programE :: Program -> E+programE prog = ELetRec (programDs prog) (EVar (progMainEntry prog))++programEsMap :: Monad m => Program -> m (Map.Map Name (TVr,E))+programEsMap prog = do+    let f d@(v,_) = case fromId (tvrIdent v) of+            Just n -> return (n,d)+            Nothing -> fail $ "Program.programEsMap: top level var with temporary name " ++ show v+    xs <- mapM f (programDs prog)+    return (Map.fromList xs)++programMapBodies :: Monad m => (E -> m E) -> Program -> m Program+programMapBodies f prog = do+    let f' (t,e) = f e >>= \e' -> return (t,e')+    programMapDs f' prog++programMapDs :: Monad m => ((TVr, E) -> m (TVr, E)) -> Program -> m Program+programMapDs f prog = do+    cs <- forM (progCombinators prog) $ \comb -> do+        (t,e) <- f (combHead comb,combBody comb)+        return . combHead_s t . combBody_s e $ comb+    return $ progCombinators_s cs prog++programMapDs_ :: Monad m => ((TVr,E) -> m ()) -> Program -> m ()+programMapDs_ f prog = mapM_ f (programDs prog)++hPrintProgram fh prog@Program {progCombinators = cs, progDataTable = dataTable } = do+    sequence_ $ intersperse (hPutStrLn fh "") [ hPrintCheckName fh dataTable v e |+                                                Comb { combHead = v, combBody = e } <- cs]+    when (progMain prog /= emptyId) $+        hPutStrLn fh $ "MainEntry: " ++ pprint (progMainEntry prog)+    when (progEntry prog /= singleton (progMain prog)) $+        hPutStrLn fh $ "EntryPoints: " ++ hsep (map pprint (progEntryPoints prog))++printProgram prog = hPrintProgram stderr prog++printCheckName'' = hPrintCheckName stderr++hPrintCheckName :: Handle -> DataTable -> TVr -> E -> IO ()+hPrintCheckName fh dataTable tvr e = do+    let (ty,pty) = case runContextEither (inferType dataTable [] e) of+            Left err -> (Unknown,vcat $ map text (intersperse "---" $ tail err))+            Right ty -> (ty,pprint ty)+        tmatch = isJust $ match (const Nothing) [] ty (tvrType tvr)+    when (dump FD.EInfo || verbose2) $ hPutStrLn fh (show $ tvrInfo tvr)+    hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "::" <+> (pprint $ tvrType tvr)))+    when (ty /= Unknown && (not tmatch || dump FD.EVerbose)) $+        hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "::" <+> pty))+    hPutStrLn fh (render $ hang 4 (pprint tvr <+> equals <+> pprint e))+    when (ty == Unknown) $+        hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "TypeError:" </> pty))
+ src/E/Rules.hs view
@@ -0,0 +1,263 @@+module E.Rules(+    ARules,+    Rule(Rule,ruleHead,ruleBinds,ruleArgs,ruleBody,ruleUniq,ruleName),+    RuleType(..),+    Rules(..),+    applyRules,+    arules,+    builtinRule,+    dropArguments,+    fromRules,+    ruleUpdate,+    mapRBodyArgs,+    makeRule,+    mapBodies,+    printRules,+    rulesFromARules+    )where++import Control.Monad.Writer(execWriterT,liftM,tell)+import Data.Maybe+import Data.Monoid(Monoid(..))+import qualified Data.Traversable as T++import Data.Binary+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.Binary()+import E.E+import E.Show()+import E.Subst+import E.Values+import GenUtil+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import Options+import Stats+import StringTable.Atom(toAtom)+import Support.CanType+import Support.FreeVars+import Support.MapBinaryInstance()+import Util.HasSize+import Util.SetLike as S+import qualified Util.Seq as Seq++instance Show Rule where+    showsPrec _ r = shows $ ruleName r++emptyRule :: Rule+emptyRule = Rule {+    ruleHead = error "ruleHead undefined",+    ruleArgs = [],+    ruleNArgs = 0,+    ruleBinds = [],+    ruleType = RuleUser,+    ruleBody = error "ruleBody undefined",+    ruleName = error "ruleName undefined",+    ruleUniq = error "ruleUniq undefined"+    }++-- a collection of rules++newtype Rules = Rules (IdMap [Rule])+    deriving(HasSize,IsEmpty)++instance Eq Rule where+    r1 == r2 = ruleUniq r1 == ruleUniq r2++instance Binary Rules where+    put (Rules mp) = put (concat $ values mp)+    get = do+        rs <- get+        return $ fromRules rs++mapBodies :: Monad m => (E -> m E) -> Rules -> m Rules+mapBodies g (Rules mp) = do+    let f rule = do+            b <- g (ruleBody rule)+            return rule { ruleBody = b }+    mp' <- T.mapM (mapM f) mp+    return $ Rules mp'+    --mp' <- sequence [ do rs' <- mapM f rs; return (k,rs') | (k,rs) <- Map.toAscList mp ]+    --return $ Rules $ Map.fromAscList mp'++instance FreeVars Rule [Id] where+    freeVars rule = idSetToList $ freeVars rule++{-# NOINLINE printRules #-}+printRules ty (Rules rules) = mapM_ (\r -> printRule r >> putChar '\n') [ r | r <- concat $ values rules, ruleType r == ty ]++putDocMLn' :: Monad m => (String -> m ()) -> Doc -> m ()+putDocMLn' putStr d = displayM putStr (renderPretty 0.80 (optColumns options) d) >> putStr "\n"++printRule Rule {ruleName = n, ruleBinds = vs, ruleBody = e2, ruleHead = head, ruleArgs = args } = do+    let e1 = foldl EAp (EVar head) args+    let p v = parens $ pprint v <> text "::" <> pprint (getType v)+    putDocMLn' putStr $  (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "."+    let ty = pprint $ getType e1 -- case inferType dataTable [] e1 of+    --    ty2 = pprint $ getType e2+    putDocMLn' putStr (indent 2 (pprint e1) <+> text "::" <+> ty )+    putDocMLn' putStr $ text " ==>" <+> pprint e2+    --putDocMLn CharIO.putStr (indent 2 (pprint e2))+    --putDocMLn CharIO.putStr (indent 2 (text "::" <+> ty2))++combineRules as bs = map head $ sortGroupUnder ruleUniq (as ++ bs)++instance Monoid Rules where+    mempty = Rules mempty+    mappend (Rules x) (Rules y) = Rules $ unionWith combineRules x y++fromRules :: [Rule] -> Rules+fromRules rs = Rules $ fmap snds $ fromList $ sortGroupUnderF fst [ (tvrIdent $ ruleHead r,ruleUpdate r) | r <- rs ]++mapRBodyArgs :: Monad m => (E -> m E) -> Rule -> m Rule+mapRBodyArgs g r = do+    let f rule = do+            b <- g (ruleBody rule)+            as <- mapM g (ruleArgs rule)+            return rule { ruleArgs = as, ruleBody = b }+    f r++rulesFromARules :: ARules -> [Rule]+rulesFromARules = aruleRules++-- replace the given arguments with the E values, dropping impossible rules+dropArguments :: [(Int,E)] -> [Rule] -> [Rule]+dropArguments os  rs  = catMaybes $  map f rs where+    f r = do+        let g (i,a) | Just v <- lookup i os = do+                rs <- match (const Nothing) (ruleBinds r) a v+                return (Right rs)+            g (i,a) = return (Left a)+        as' <- mapM g $ zip naturals (ruleArgs r)+        let sb = substLet (concat $ rights as')+            sa = substMap $ fromList [ (tvrIdent t,v) |  Right ds <- as', (t,v) <- ds ]+        return r { ruleArgs = map sa (lefts as'), ruleBody = sb (ruleBody r) }++-- | ARules contains a set of rules for a single id, optimized for fast application+--+-- invarients for ARules+-- sorted by number of arguments rule takes+-- all hidden rule fields filled in+-- free variables are up to date++instance Show ARules where+    showsPrec n a = showsPrec n (aruleRules a)++arules xs = ARules { aruleFreeVars = freeVars rs, aruleRules = rs } where+    rs = sortUnder ruleNArgs (map f xs)+    f rule = rule {+        ruleNArgs = length  (ruleArgs rule),+        ruleBinds = bs,+        ruleBody = g (ruleBody rule),+        ruleArgs = map g (ruleArgs rule)+        } where+        bs = map (setProperty prop_RULEBINDER) (ruleBinds rule)+        g e = substMap (fromList [ (tvrIdent t, EVar t) | t <- bs ]) e++instance Monoid ARules where+    mempty = ARules { aruleFreeVars = mempty, aruleRules = [] }+    mappend = joinARules++ruleUpdate rule = rule {+        ruleNArgs = length  (ruleArgs rule),+        ruleBinds = bs,+        ruleBody = g (ruleBody rule),+        ruleArgs = map g (ruleArgs rule)+    } where+        bs = map (setProperty prop_RULEBINDER) (ruleBinds rule)+        g e = substMap (fromList [ (tvrIdent t, EVar t) | t <- bs ]) e++joinARules ar@(ARules fvsa a) br@(ARules fvsb b)+    | [] <- rs = ARules mempty []+    | all (== r) rs = ARules (fvsa `mappend` fvsb) (sortUnder (\r -> (ruleNArgs r,ruleUniq r)) (snubUnder ruleUniq $ a ++ b))+    | otherwise = error $ "mixing rules!" ++ show (ar,br) where+   rs@(r:_) = map ruleHead a ++ map ruleHead b++rsubstMap :: IdMap E -> E -> E+rsubstMap im e = doSubst False True (fmap ( (`mlookup` im) . tvrIdent) (unions $ (freeVars e :: IdMap TVr):map freeVars (values im))) e++applyRules :: MonadStats m => (Id -> Maybe E) -> ARules -> [E] -> m (Maybe (E,[E]))+applyRules lup (ARules _ rs) xs = f rs where+    lxs = length xs+    f [] = return Nothing+    f (r:_) | ruleNArgs r > lxs = return Nothing+    f (r:rs) = case sequence (zipWith (match lup (ruleBinds r)) (ruleArgs r) xs) of+        Just ss -> do+            mtick (ruleName r)+            let b = rsubstMap (fromList [ (i,x) | (TVr { tvrIdent = i },x) <- concat ss ]) (ruleBody r)+            return $ Just (b,drop (ruleNArgs r) xs)+        Nothing -> do f rs++preludeError = toId v_error+ruleError = toAtom "Rule.error/EError"++builtinRule TVr { tvrIdent = n } (ty:s:rs)+    | n == preludeError, Just s' <- toString s  = do+        mtick ruleError+        return $ Just ((EError ("Prelude.error: " ++ s') ty),rs)+builtinRule _ _ = return Nothing++makeRule ::+    String      -- ^ the rule name+    -> (Module,Int)  -- ^ a unique name for this rule+    -> RuleType -- ^ type of rule+    -> [TVr]    -- ^ the free variables+    -> TVr      -- ^ the head+    -> [E]      -- ^ the args+    -> E        -- ^ the body+    -> Rule+makeRule name uniq ruleType fvs head args body = rule where+    rule = emptyRule {+        ruleHead = head,+        ruleBinds = fvs,+        ruleArgs = args,+        ruleType = ruleType,+        ruleNArgs = length args,+        ruleBody = body,+        ruleUniq = uniq,+        ruleName = toAtom $ "Rule.User." ++ name+        }++-- | find substitution that will transform the left term into the right one,+-- only substituting for the vars in the list++match :: Monad m =>+    (Id -> Maybe E)      -- ^ function to look up values in the environment+    -> [TVr]              -- ^ vars which may be substituted+    -> E                  -- ^ pattern to match+    -> E                  -- ^ input expression+    -> m [(TVr,E)]+match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () etherealIds) where+    bvs :: IdSet+    bvs = fromList (map tvrIdent vs)++    un _ _ _ c | c `seq` False = undefined+    un (EAp a b) (EAp a' b') mm c = do+        un a a' mm c+        un b b' mm c+    un (ELam va ea) (ELam vb eb) mm c = lam va ea vb eb mm c+    un (EPi va ea) (EPi vb eb) mm c = lam va ea vb eb mm c+    un (EPrim s xs t) (EPrim s' ys t') mm c | length xs == length ys = do+        sequence_ [ un x y mm c | x <- xs | y <- ys]+        un t t' mm c+    un (ESort x) (ESort y) mm c | x == y = return ()+    un (ELit (LitInt x t1))  (ELit (LitInt y t2)) mm c | x == y = un t1 t2 mm c+    un (ELit LitCons { litName = n, litArgs = xs, litType = t })  (ELit LitCons { litName = n', litArgs = ys, litType =  t'}) mm c | n == n' && length xs == length ys = do+        sequence_ [ un x y mm c | x <- xs | y <- ys]+        un t t' mm c++    un (EVar TVr { tvrIdent = i, tvrType =  t}) (EVar TVr {tvrIdent = j, tvrType =  u}) mm c | i == j = un t u mm c+    un (EVar TVr { tvrIdent = i, tvrType =  t}) (EVar TVr {tvrIdent = j, tvrType =  u}) mm c | isEtherealId i || isEtherealId j  = fail "Expressions don't match"+    un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b mm c+        | i `member` bvs = tell (Seq.single (tvr,b))+        | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b+    un a (EVar tvr) mm c | Just b <- lup (tvrIdent tvr), not $ isEVar b = un a b mm c++    un a b _ _ = fail $ "Expressions do not unify: " ++ show a ++ show b+    lam va ea vb eb mm ~(c:cs) = do+        un (tvrType va) (tvrType vb) mm (c:cs)+        un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm cs
+ src/E/SStrictness.hs view
@@ -0,0 +1,280 @@+module E.SStrictness(+    analyzeProgram+    ) where++import Control.Monad+import Control.Monad.RWS+import Data.FunctorM+import Data.List+import Data.Typeable+import qualified Data.Map as Map++import Doc.PPrint+import E.E+import E.Program+import GenUtil+import Info.Info as Info+import Name.Id+import Util.BooleanSolver+import Util.SetLike++-- our 2 point lattice+-- True == strict+-- False == not strict++type SL = Bool++x `islte` y = x `implies` y+x `isgte` y = y `implies` x++data TAnot l = TAnot l (TTyp l)+    deriving (Eq,Typeable)++data TTyp l = (TAnot l) `TFun` (TAnot l) | TAtomic | TCPR [TAnot l]+    deriving (Eq,Typeable)++type Typ = TAnot (CV (CA Var))++instance Functor TAnot where+    fmap f (TAnot l t) = TAnot (f l) (fmap f t)++instance Functor TTyp where+    fmap _ TAtomic = TAtomic+    fmap f (x `TFun` y) = fmap f x `TFun` fmap f y+    fmap f (TCPR xs) = TCPR $ map (fmap f) xs++instance FunctorM TAnot where+    fmapM f (TAnot l t) = do l <- f l; t <- fmapM f t; return $ TAnot l t++instance FunctorM TTyp where+    fmapM _ TAtomic = return TAtomic+    fmapM f (x `TFun` y) = do x <- fmapM f x; y <- fmapM f y; return $ x `TFun` y+    fmapM f (TCPR xs) = do xs <- mapM (fmapM f) xs; return $ TCPR xs++instance Show l => Show (TAnot l) where+    showsPrec d (TAnot l typ) = showParen (d > 10) $ showsPrec 11 typ . showString "^" . showsPrec 11 l++instance Show l => Show (TTyp l) where+    showsPrec d (t1 `TFun` t2) = showParen (d > 9) $ showsPrec 10 t1 . showString " -> " . showsPrec 10 t2+    showsPrec _ TAtomic = showString "@"+    showsPrec d (TCPR ts) = showParen True $ foldr (.) id (intersperse (showString ",") (map shows ts))++newtype Var = V Int+    deriving(Eq,Ord,Typeable)++instance Show Var where+    showsPrec _ (V x) = ('v':) . shows x++type Constraints = C (CA Var)++type Environment = Map.Map Id Typ++newtype IM a = IM (RWST Environment Constraints Int IO a)+    deriving(MonadState Int,MonadReader Environment,MonadWriter Constraints,Monad,Functor,MonadIO)++newVar :: IM Var+newVar = do+    v <- get+    put (v + 1)+    return (V v)++newtype ShowString = ShowString String++instance Show ShowString where+    showsPrec _ (ShowString s) = showString s++fn (CJust v) = ShowString (show v)+fn CTrue = ShowString "S"+fn CFalse = ShowString "L"++strict,lazy :: CV (CA Var)+strict = CTrue+lazy = CFalse++data Variance = Nowhere | Positive | Negative | Both+    deriving(Eq,Ord,Show)++instance Monoid Variance where+    mempty = Nowhere+    mappend x y | x == y = x+    mappend Positive Negative = Both+    mappend Negative Positive = Both+    mappend Nowhere x = x+    mappend x Nowhere = x++flipVariance Positive = Negative+flipVariance Negative = Positive+flipVariance x = x++collect :: Typ -> [(Var,Variance)]+collect t = execWriter $ f Positive t where+    f p (TAnot (CJust v) t) = tell [(fromCA v,p)] >> g p t+    f p (TAnot _ t) = g p t+    g p TAtomic = return ()+    g p (x `TFun` y) = f (flipVariance p) x >> f p y++{-# NOINLINE analyzeProgram #-}+analyzeProgram prog = do+    flip mapM_ (programDs prog) $ \ (t,e) -> case (runIM (infer e)) of+        Left err -> putStrLn $ "strictness error :" ++ pprint t ++ "\n" ++ err+        Right (c,(ty,_)) -> do+            putStrLn $ "strictnes " ++ pprint t+            print c+            let cc (TAnot l TAtomic) = strict `islte` l+                cc (TAnot _ (_ `TFun` b)) = cc b+            print (fmap fn ty)+            putStrLn "solving:"+            --(cc,cvs) <- groundConstraints $ c -- `mappend` cc ty+            processConstraints True c+--            rs <- flip mapM cvs $ \cv -> do+--                res <- readValue cv+--                let rr = case res of+--                        ResultJust True -> CTrue+--                        ResultJust False -> CFalse+--                        ResultBounded a _ _ -> CJust (fromCA a)+--                return (fromCA cv, rr )+--            let mp :: Map.Map Var (CV Var)+--                mp = Map.fromList rs+--                zz (CJust x) | Just y <- Map.lookup x (Map.fromList rs) = y+--                zz (CJust y) = CJust y+--                zz CTrue = CTrue+--                zz CFalse = CFalse+--                ty' = fmap zz ty+--            print (fmap fn ty)+--            let varmap = (Map.fromListWith mappend $ collect ty')+--            print varmap+--            flip mapM_ cvs $ \cv -> do+--                res <- readValue cv+--                print (fromCA cv,fmap fromCA res)+--            --print (fmap (zz . CJust . fromCA) cc)++    return ()++runIM :: MonadIO m => IM a -> m (Constraints,a)+runIM (IM s) = do+    (a,_,c) <- liftIO $ runRWST s mempty 1+    return (c,a)++atom = TAnot lazy TAtomic++mkVar :: IM (CV (CA Var))+mkVar = do+    v <- newVar+    ca <- mkCA v+    return (CJust ca)++infer :: E -> IM (Typ,E)+infer e@(ELit l) = do+    return (TAnot strict TAtomic,e)+    --return (atom,e)+infer e@EPi {} = do+    return (TAnot strict TAtomic,e)+    --return (atom,e)+infer (EVar tvr) = do+    env <- ask+    case mlookup (tvrIdent tvr) env `mplus` Info.lookup (tvrInfo tvr) of+        Nothing -> do+            -- guess a pessimistic type if we know nothing about a variable+            t <- guessType (tvrType tvr)+            return (t,EVar tvr)+        Just t -> return (t,EVar tvr)+infer (EPrim p xs t) = do+    ts <- mapM infer xs+    v <- mkVar+    mapM_ (\ (TAnot t _) -> tell (v `islte` t)) (map fst ts)+    return (TAnot v TAtomic,EPrim p (map snd ts) t)+infer (EError s t) = do+    v <- mkVar+    return (TAnot v TAtomic,EError s t)+infer (ELam x@TVr {tvrType = t1} m) = do+    s1 <- freshAnot t1+    (s2,e) <- local (minsert (tvrIdent x) s1) $+        infer m+    v <- mkVar+    return (TAnot strict $ s1 `TFun` s2,ELam x e)+infer ec@ECase {} = do+    nv <- mkVar+    (TAnot t _,e') <- infer (eCaseScrutinee ec)+    tell (nv `implies` t)+    ((ty:tys) ,ec) <- caseBodiesMapM' infer ec+    (TAnot res rt) <- foldM freshGLB ty tys+    tell (nv `implies` res)+    return (TAnot nv rt,ec { eCaseScrutinee = e' })+infer (EAp a b) = do+    (TAnot k (s1 `TFun` (TAnot rst s2)),a) <- infer a+    (s1'@(TAnot zz _),b) <- infer b+    s1 `subsA` s1'+    res <- mkVar+    -- the function is strict if we are strict+    tell (res `implies` k)+    tell (res `implies` rst)+    return (TAnot res s2,EAp a b)+--infer (ELetRec ds e) = do++infer e = fail $ "infer: unsupported\n" ++ show e++caseBodiesMapM' :: Monad m => (E -> m (t,E)) -> E -> m ([t],E)+caseBodiesMapM' f ec@ECase { eCaseAlts = as, eCaseDefault = d } = do+    let g (Alt l e) = do (t,e) <- f e ; return (t,Alt l e)+    as' <- mapM g as+    d' <- fmapM f d+    let ts = fsts as' ++ maybe [] ((:[]) . fst) d'+    return $ (ts,ec { eCaseAlts = snds as', eCaseDefault = fmap snd d' })+caseBodiesMapM' _ _ = error "caseBodiesMapM'"++-- | pessimistic guess of type for variables we know nothing about.+-- warning! newtypes of infinite functions are wonky. need to figure out solution.+guessType (EPi TVr {tvrType = t1 } t2) = do+    TAnot _ t1 <- guessType t1+    t2 <- guessType t2+    v <- mkVar+    return (TAnot v $ TAnot lazy t1 `TFun` t2)+guessType _ = do+    v <- mkVar+    return (TAnot v TAtomic)++freshAnot (EPi TVr {tvrType = t1 } t2) = do+    t1 <- freshAnot t1+    t2 <- freshAnot t2+    v <- mkVar+    return (TAnot v $  t1 `TFun` t2)+freshAnot _ = do+    v <- mkVar+    return (TAnot v TAtomic)++freshGLB (TAnot k1 TAtomic) (TAnot k2 TAtomic) = do+    v <- mkVar+    tell (v `islte` k1)+    tell (v `islte` k2)+    return (TAnot v TAtomic)++freshGLB (TAnot k1 (TFun a1 b1)) (TAnot k2 (TFun a2 b2)) = do+    v <- mkVar+    tell (v `islte` k1)+    tell (v `islte` k2)+    a <- freshLUB a1 a2+    b <- freshGLB a2 b2+    return (TAnot v (TFun a b))++freshLUB (TAnot k1 TAtomic) (TAnot k2 TAtomic) = do+    v <- mkVar+    tell (v `isgte` k1)+    tell (v `isgte` k2)+    return (TAnot v TAtomic)++freshLUB (TAnot k1 (TFun a1 b1)) (TAnot k2 (TFun a2 b2)) = do+    v <- mkVar+    tell (v `isgte` k1)+    tell (v `isgte` k2)+    a <- freshLUB a1 a2+    b <- freshGLB a2 b2+    return (TAnot v (TFun a b))++subs (x1 `TFun` y2) (x3 `TFun` y4) = do+    x3 `subsA` x1+    y2 `subsA` y4+subs TAtomic TAtomic = return ()++subsA (TAnot a t1) (TAnot b t2) = do+    tell (a `islte` b)+    t1 `subs` t2
+ src/E/Show.hs view
@@ -0,0 +1,258 @@+module E.Show(ePretty,render,prettyE) where++import Control.Monad.Identity+import Data.Char(chr)+import Data.Maybe++import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.E+import E.FreeVars()+import E.TypeCheck+import Name.Id+import Name.Name+import Name.Names+import Name.VConsts+import Options+import Support.FreeVars+import Support.Unparse+import Util.SetLike+import Util.VarName+import qualified Data.Map as Map+import qualified Doc.Chars as UC+import qualified FlagDump as FD++{-# NOINLINE render #-}+{-# NOINLINE ePretty #-}+{-# NOINLINE prettyE #-}+render :: Doc -> String+render doc =  displayS (renderPretty 100.0 (optColumns options)  doc) ""++prettyE :: E -> String+prettyE e = render $ ePretty e++instance DocLike d => PPrint d TVr where+    pprint TVr { tvrIdent = i }  = pprint i++instance PPrint Doc E where+    pprint x = ePretty x++instance PPrint String E where+    pprintAssoc a i x = render $ pprintAssoc a i x++instance PPrint String (Lit E E) where+    pprintAssoc _ n x | n <= 9    = prettyE (ELit x)+                      | otherwise = parens (prettyE (ELit x))++newtype SEM a = SEM { _unSEM :: VarNameT E Id String Identity a }+    deriving(Monad,Functor)++enumList = [+    (tc_Bool_,["False#","True#"]),+    (toName TypeConstructor ("Jhc.Order","Ordering#"),["LT#","EQ#","GT#"])+    ]++showLit ::+    (a -> SEM (Unparse Doc))   -- ^ routine for showing the contents of constructor literals+    -> Lit a E                 -- ^ the literal to show+    -> SEM (Unparse Doc)       -- ^ the final result+showLit showBind l = do+    let f (LitInt i (ELit LitCons { litName = n })) | Just l <- lookup n enumList, i >= 0 && fromIntegral i < length l =+            return $ atom $ ((text $ l !! (fromIntegral i)))+        f (LitInt n (ELit LitCons { litName = t})) | t == tc_Char_ = return $ atom $ tshow (chr $ fromIntegral n) <> char '#'+        f (LitInt i t) | dump FD.EVerbose = do+            se <- showE t+            return $ (atom (text $ show i) `inhabit` se )+        f (LitInt i _) = return $ atom $ ((text $ show i))+        f LitCons { litName = s, litArgs = es } | Just n <- fromTupname s , n == length es = do+            es' <- mapM (fmap unparse . showBind) es+            return $ atom $ tupled es'+        f LitCons { litName = s, litArgs = es } | Just n <- fromUnboxedNameTuple s, n == length es = do+            es' <- mapM (fmap unparse . showBind) es+            return $ atom $ encloseSep (text "(# ") (text " #)") (text ", ") es'+        f LitCons { litName = n, litArgs = [a,b] } | dc_Cons == n  = do+            a' <- showBind a+            b' <- showBind b+            return $ a' `cons` b'+        f LitCons { litName = n, litArgs = [e] } | tc_List == n = do+            e <- showBind e+            return $  atom   (char '[' <> unparse e  <> char ']')+        f LitCons { litName = n, litArgs = [] } | dc_EmptyList == n = return $ atom $ text "[]"+--        f LitCons { litName = n, litArgs = [] } | Just m <- getModule n, m `elem`[toModule "Jhc.Prim.Bits", toModule "Jhc.Prim.Word"]  = return $ atom $ text "[]"+--        f LitCons { litName = ((tc_Addr_ ==) -> True), litType = ((eHash ==) -> True) } = return $ atom $ text "Addr_"+--        f LitCons { litName = ((tc_FunAddr_ ==) -> True), litType = ((eHash ==) -> True) } = return $ atom $ text "FunAddr_"+--        f LitCons { litName = ((tc_Char_ ==) -> True), litType = ((eHash ==) -> True) } = return $ atom $ text "Char_"+--        f LitCons { litName = n, litArgs = [v] }+--        f LitCons { litName = n, litArgs = [v] }+--            | n == dc_Integer = go "Integer#"+--            | n == dc_Int     = go "Int#"+--            | n == dc_Char    = go "Char#"+--          where go n = do+--                    se <- showBind v+--                    return $ atom (text n) `app` se+        f LitCons { litName = s, litArgs = es, litType = t,+		    litAliasFor = Just af } | dump FD.EAlias = do+	    s <- return $ fromMaybe s (shortenName s)+            es' <- mapM showBind es+            se <- showE af+            return $ foldl appCon (atom (tshow s <> char '@' <> parens (unparse se))) es' -- `inhabit` prettye t+        f LitCons { litName = s, litArgs = es, litType = t } = do+	    s <- return $ fromMaybe s (shortenName s)+            es' <- mapM showBind es+            return $ foldl appCon (atom (tshow s)) es' -- `inhabit` prettye t+        cons = bop (R,5) (text ":")+	shortenName n = Map.lookup n shortName `mplus` (getModule n >>= mm) where+	    mm m = if m `elem` shortMods then return (toUnqualified n) else Nothing+            shortMods = map toModule [ "Jhc.Prim.IO", "Jhc.Prim.Bits", "Jhc.Type.Word", "Jhc.Type.C" ]+    f l++app = bop (L,100) (text " ")+appCon = bop (L,99) (text " ")++showI i = do+    n <- SEM $ maybeLookupName i+    case n of+        Nothing -> pprint i+        Just n -> text n++showTVr :: TVr -> SEM (Unparse Doc)+showTVr TVr { tvrIdent = i, tvrType =  t, tvrInfo = nfo}  = do+    let si = if dump FD.EInfo then (<> tshow nfo) else id+    ty <- showE t+    ii <- showI i+    return $ atom (si ii) `inhabit` ty+showTVr' TVr { tvrIdent = i} = do+    ii <- showI i+    return $ atom ii++allocTVr :: TVr -> SEM a -> SEM a+allocTVr _tvr action | dump FD.EVerbose = action+allocTVr tvr action | tvrIdent tvr == emptyId = action+allocTVr tvr (SEM action) | tvrType tvr == eStar  = do+    SEM $ subVarName $ newName (map (:[]) ['a' ..]) eStar (tvrIdent tvr) >> action+allocTVr tvr (SEM action) | tvrType tvr == eStar `tFunc` eStar  = do+    SEM $ subVarName $ newName (map (('f':) . show) [0::Int ..])  (tvrType tvr) (tvrIdent tvr) >> action+allocTVr tvr (SEM action) | not $ isJust (fromId (tvrIdent tvr)) = do+    SEM $ subVarName $ newName (map (('v':) . show) [1::Int ..]) Unknown (tvrIdent tvr) >> action+allocTVr _ action = action++-- collects lambda and pi abstractions+collectAbstractions e0 = go e0 [] where+    go e1@(EPi tvr e)  xs | tvrIdent tvr == emptyId          = done e1 xs+                          | not (sortKindLike (tvrType tvr)) = go e ((UC.pI,     tvr, True) :xs)+                          | tvrType tvr /= eStar             = go e ((UC.forall, tvr, True) :xs)+                          | dump FD.EVerbose || tvrIdent tvr `member` (freeVars e::IdSet)+                                                             = go e ((UC.forall, tvr, False):xs)+                          | otherwise                        = done e1 xs+    go e1@(ELam tvr e) xs | tvrType tvr == eStar             = go e ((UC.lAmbda, tvr, False):xs)+                          | sortKindLike (tvrType tvr)       = go e ((UC.lAmbda, tvr, True) :xs)+                          | otherwise                        = go e ((UC.lambda, tvr, True) :xs)+    go  e           xs = done e xs+    done e xs = (reverse xs, e)++short_names = [+      tc_Bool,      tc_Char,     tc_IO,      tc_ACIO,    tc_State_,+      tc_RealWorld, tc_Ordering, tc_Bool_,   tc_Ratio,   tc_Float,+      tc_Double,    tc_Ptr,      tc_FunPtr,  tc_Integer, tc_Addr_,+      tc_FunAddr_,  tc_Char_,    dc_Boolzh,  dc_Char,    dc_Integer,+      tc_ST,        tc_Bang_]++shortName = Map.fromList [ (x, toUnqualified x) | x <- short_names]++showE :: E -> SEM (Unparse Doc)+showE e = do+    let f e | Just s <- E.E.toString e = return $ atom $ (text $ show s)+        f e | Just xs <- eToList e = do+            xs <- mapM (fmap unparse . showE) xs+            return $ atom $ list xs+        f e | e == tRational = return $ atom $ text "Rational"+        f e | e == tString   = return $ atom $ text "String"+        f e | e == tUnit     = return $ atom $ text "()"+        f e | e == tWorld__  = return $ atom $ text "RealWorld_"+        f e | e == vUnit     = return $ atom $ text "()"+        f (EAp a b) = liftM2 app (showE a) (showE b)+        f (EPi (TVr { tvrIdent = eid, tvrType =  e1}) e2) | eid == emptyId = liftM2 arr (showE e1) (showE e2)+        f (EPi (TVr { tvrIdent = n, tvrType =  e1}) e2) | not $ dump FD.EVerbose, not $ n `member` (freeVars e2 ::IdSet) = liftM2 arr (showE e1) (showE e2)+        f e0 | (as@(_:_), e) <- collectAbstractions e0 =+            foldr (\(_, tvr, _) -> allocTVr tvr)+                  (do tops <- mapM p as+                      e <- showE e+                      return (fixitize (N,1) $ atom $ group $ (align $ skipToNest <> fillCat tops) <$> unparse e))+                  as+            where+              p :: (Doc, TVr, Bool) -> SEM Doc+              p (c,t,detailed) = do tvr <- if detailed then showTVr t else showTVr' t+                                    return (c <> unparse tvr <> (char '.'))+        f (EVar tvr) = if dump FD.EVerbose then showTVr tvr else showTVr' tvr+        f Unknown = return $ symbol (char  '?')+        f (ESort s) = return $ symbol (tshow s)+        f (ELit (LitCons { litName = n, litArgs = [ELit (LitInt i _)] })) | n == dc_Char = return $ atom $ tshow $ chr (fromIntegral i)+        f (ELit l) = showLit showE l+        f (EError "" t) = do+            ty <- showE t+            return $ atom $ angles (text "exitFailure"  <>  UC.coloncolon <> unparse ty)+        f (EError s t) = do+            ty <- showE t+            return $ atom $ angles ( UC.bottom <> char ':' <> text s <>  UC.coloncolon <> unparse ty)+        f (EPrim s es t) = do+            es' <- mapM showE es+            t <- showE t+            return $ atom $ angles $ unparse $ foldl app (atom (pprint s)) es' `inhabit` t+        f ELetRec { eDefs = ds, eBody = e } = foldr (\(tvr,_) -> allocTVr tvr) (do+            e <- fmap unparse $ showE e+            ds <- mapM (fmap unparse . showDecl) ds+            return $ fixitize (N,98) $ atom $ nest 2 (group ( keyword "let"+                                                                  <$> (align $ sep (map (<> char ';') ds))+                                                                  <$> (keyword "in")) </> e )) ds++        f ec@(ECase { eCaseScrutinee = e, eCaseAlts = alts }) = mt (showE (eCaseType ec)) $  allocTVr (eCaseBind ec) $ do+            scrut <- fmap unparse $ showE e+            alts <- mapM showAlt alts+            let ecb = eCaseBind ec+                isUsed = tvrIdent ecb `member` (freeVars (caseBodies ec) :: IdSet)+            db <- showTVr (if dump FD.EVerbose || isUsed then ecb else ecb { tvrIdent = emptyId })+            dcase <- case (eCaseDefault ec) of+                Nothing -> return []+                Just e -> do+                    e <- showE e+                    return [unparse db <+> UC.rArrow </> unparse e]+            let alts' = map (\a -> nest 2 (group (a <> char ';'))) (alts ++ dcase)+            let mbind | isJust (eCaseDefault ec) = empty+                      | (isUsed && isNothing (eCaseDefault ec)) || dump FD.EVerbose = text " " <> (if isUsed then id else (char '_' <>)) (unparse db) <+> text "<-"+                      | otherwise = empty+            return $ fixitize ((N,98)) $ atom $+                group (nest 2 ( keyword "case" <> mbind <+> scrut <+> keyword "of" <$>  (align $ vcat alts')) )+        f _ = error "undefined value in E.Show"+        showAlt (Alt l e) = foldr allocTVr ans (litBinds l) where+            ans = do+                l <- showLit showTVr l+                e <- showE e+                return $ unparse l <+> UC.rArrow </> unparse e+        showDecl (t,e) = do+            t <- subSEM $ showTVr t+            e <- subSEM $ showE e+            return $ atom $ nest 2 $ group $ unparse t <+> (char '=') </> unparse e+        keyword x = text x+        symbol x = atom x+        arr = bop (R,0) $ (space <> UC.rArrow <> space)+        mt t x | dump FD.EVerbose = do+                    t <- t+                    x <- x+                    return $ x `inhabit` t+        mt _ x = x++    f e++subSEM (SEM act) = SEM $ subVarName act+inhabit = bop (N,-2) $ UC.coloncolon++ePretty e = unparse pe where+    (SEM pe') = showE e+    Identity pe = runVarNameT pe'++-- skip to the current nesting level, breaking the line if already past it+skipToNest      = column (\k ->+                  nesting (\i -> if k > i+                                 then linebreak+                                 else text (replicate (i-k) ' ')))
+ src/E/Show.hs-boot view
@@ -0,0 +1,17 @@+-- -*- Haskell -*-++module E.Show(ePretty,render,prettyE) where++import E.E+import Doc.DocLike+import Doc.Pretty+import Doc.PPrint++render :: Doc -> String+prettyE :: E -> String+ePretty :: E -> Doc++instance DocLike d => PPrint d TVr+instance PPrint Doc E+instance PPrint String E+instance PPrint String (Lit E E)
+ src/E/Subst.hs view
@@ -0,0 +1,279 @@+module E.Subst(+    doSubst,+    doSubst',+    eAp,+    litSMapM,+    subst,+    subst',+    substMap,+    substMap',+    substMap'',+    typeSubst,+    typeSubst'+    ) where++-- This is a little tricky.++{-+Consider the following example.+fn = \x0 -> let x1 = 10+x0      -- x1 is only used once, let's inline it.+            in (\x0 -> x1+x0)   -- x0 from the outer lambda isn't used.++Simply inlining x1 will give this errornous result:+fn = \x0 -> (\x0 -> (10+x0)+x0)++We solve this by renaming variable whenever they clash with the current scope:+fn = \x0 -> (\x1 -> (10+x0)+x1)++Another solution would be to assign a globally unique id to each variable. However,+in a pure and lazy language like Haskell, renaming variables on the fly is easier+and quite fast.++New ids are currently generated by selecting psuedo random numbers and checking if+they're free. Another posibility would be to select the highest known id number + 1.+See Name.Id.newId for more information.++-}++import Control.Monad.Reader+import qualified Data.Set as Set+import qualified Data.Traversable as T++import E.E+import E.FreeVars()+import GenUtil+import Name.Id+import Name.Names+import Support.FreeVars+import Util.HasSize+import Util.SetLike as S++--eLetRec :: [(TVr,E)] -> E -> E+--eLetRec ds e = f (filter ((/= emptyId) . tvrIdent . fst) ds) where+--    f [] = e+--    f ds = ELetRec ds e++-- | Basic substitution routine+subst ::+    TVr   -- ^ Variable to substitute+    -> E  -- ^ What to substitute with+    -> E  -- ^ input term+    -> E  -- ^ output term+subst (TVr { tvrIdent = eid }) _ e | eid == emptyId = e+subst (TVr { tvrIdent = i }) w e = doSubst' False False (msingleton i w) (\n -> n `member` (freeVars w `union` freeVars e :: IdSet))  e++-- | Identitcal to 'subst' except that it substitutes inside the local types+-- for variables in expressions. This should not be used because it breaks the+-- sharing of types between a binding site of a variable and its uses and can+-- lead to inconsistant terms. However, it is sometimes useful to create+-- transient terms for typechecking.++subst' :: TVr -> E -> E -> E+subst' (TVr { tvrIdent = eid }) _ e | eid == emptyId = e+subst' (TVr { tvrIdent = (i) }) w e = doSubst' True False (msingleton i w) (\n -> n `member` (freeVars w `union` freeVars e :: IdSet)) e++litSMapM f LitCons { litName = s, litArgs = es, litType = t, litAliasFor = af } = do+    t' <- f t+    es' <- mapM f es+    return $ LitCons s es' t' af+litSMapM f (LitInt n t) = do+    t' <- f t+    return $ LitInt n t'++substMap :: IdMap E -> E -> E+substMap im e = doSubst' False False im (\n -> n `member` (unions $ (freeVars e :: IdSet):map freeVars (values im))) e++-- | doesn't seed with free variables.+substMap' :: IdMap E -> E -> E+substMap' im = doSubst' False False im (`member` im)++-- | doesn't seed with free variables.+substMap'' :: IdMap (Maybe E) -> E -> E+substMap'' im = doSubst' False False (mapMaybeIdMap id im) (`member` im)++-- Monadic code is so much nicer+doSubst :: Bool -> Bool -> IdMap (Maybe E) -> E -> E+doSubst substInVars allShadow bm e+    = doSubst' substInVars allShadow (mapMaybeIdMap id bm) (`member` bm) e++doSubst' :: Bool -> Bool -> IdMap E -> (Id -> Bool) -> E -> E+doSubst' substInVars allShadow bm check e  = f e (Set.empty, bm) where+    f :: E -> (Set.Set Id, IdMap E) -> E+    f eo@(EVar tvr@(TVr { tvrIdent = i, tvrType =  t })) = do+        (_,mp) <- ask+        case mlookup i mp of+          Just v -> return v+          _+            | substInVars -> f t >>= \t' -> return $ EVar (tvr { tvrType =  t'})+            | otherwise  -> return  eo+    f (ELam tvr e) = lp ELam tvr e+    f (EPi tvr e) = lp EPi tvr e+    f (EAp a b) = liftM2 eAp (f a) (f b)+    f (EError x e) = liftM (EError x) (f e)+    f (EPrim x es e) = liftM2 (EPrim x) (mapM f es) (f e)+    f ELetRec { eDefs = dl, eBody = e } = do+        (as,rs) <- mapMntvr (fsts dl)+        local (foldr (.) id rs) $ do+            ds <- mapM f (snds dl)+            e' <- f e+            return $ ELetRec (zip as ds) e'+    f (ELit l) = liftM ELit $ litSMapM f l+    f Unknown = return Unknown+    f e@(ESort {}) = return e+    f ec@(ECase {}) = do+        e' <- f $ eCaseScrutinee ec+        (b',r) <- ntvr Set.empty $ eCaseBind ec+        d <- local r $ T.mapM f $ eCaseDefault ec+        let da (Alt lc@LitCons { litName = s, litArgs = vs, litType = t } e) = do+                t' <- f t+                (as,rs) <- mapMntvr vs+                e' <- local (foldr (.) id rs) $ f e+                return $ Alt lc { litArgs = as, litType = t' } e'+            da (Alt l e) = do+                l' <- T.mapM f l+                e' <- f e+                return $ Alt l' e'+        alts <- local r (mapM da $ eCaseAlts ec)+        nty <- f (eCaseType ec)+        return  $ caseUpdate ec { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts, eCaseType = nty }+    lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == emptyId || (allShadow && n `notElem` freeVars e) = do+        t' <- f t+        e' <- local (\(s,m) -> (Set.insert n s, delete n m)) $ f e+        return $ lam (tvr { tvrIdent =  emptyId, tvrType =  t'}) e'+    lp lam tvr e = do+        (tv,r) <- ntvr Set.empty tvr+        e' <- local r $ f e+        return $ lam tv e'+    mapMntvr ts = f ts [] where+        f [] xs = return $ unzip $ reverse xs+        f (t:ts) rs = do+            (t',r) <- ntvr vs t+            local r $ f ts ((t',r):rs)+        vs = Set.fromList [ tvrIdent x | x <- ts ]++    ntvr xs tvr@(TVr { tvrIdent = eid, tvrType =  t}) | eid == emptyId = do+        t' <- f t+        let nvr = (tvr { tvrType =  t'})+        return (nvr,id)+    ntvr xs tvr@(TVr {tvrIdent = i, tvrType =  t}) = do+        t' <- f t+        (s,ss) <- ask+        let i' = mnv allShadow xs i check s ss+        let nvr = (tvr { tvrIdent =  i', tvrType =  t'})+        return (nvr,\(s,m) -> (Set.insert i' . Set.insert i $ s, minsert i (EVar nvr) . delete i' $ m))++mnv :: Bool -> Set.Set Id -> Id -> (Id -> Bool) -> Set.Set Id -> IdMap a -> Id+mnv allShadow xs i checkTaken s ss+    | allShadow = newId (Set.size xs `mixInt` Set.size s `mixInt` size ss) (not . scheck)+    | isInvalidId i || scheck i = newId (Set.size xs `mixInt` Set.size s `mixInt` size ss) (not . check)+            -- It is very important that we don't check for 'xs' membership in the guard above.+    | otherwise = i+    where scheck n = n `member` ss || n `member` s || checkTaken n+          check n = scheck n || n `member` xs++eAp (EPi t b) e = if tvrIdent t == emptyId then b else subst t e b+eAp (ELam t b) e = if tvrIdent t == emptyId then b else subst t e b+--eAp (EPrim n es t@(EPi _ _)) b = EPrim n (es ++ [b]) (eAp t b)  -- only apply if type is pi-like+eAp (ELit LitCons { litName = arr, litArgs = [a1], litType = (EPi _ r) }) a2 | arr == tc_Arrow = EPi tvr { tvrType = a1  } a2+eAp (ELit lc@LitCons { litArgs = es, litType = (EPi t r) }) b = ELit lc { litArgs = es ++ [b], litType = subst t b r }+eAp (ELit LitCons { litArgs = es, litAliasFor = Just af }) b = foldl eAp af (es ++ [b])+--eAp a@ELit {} b = error $ "very strange application: (" ++ prettyE a ++ ") (" ++ prettyE b ++ ")"+eAp (EError s t) b = EError s (eAp t b)+eAp a b = EAp a b++typeSubst' :: IdMap E -> IdMap E -> E -> E+typeSubst' termSub typeSub e | isEmpty termSub && isEmpty typeSub = e+--typeSubst' termSub typeSub e = typeSubst  (Map.map Just termSub `Map.union` Map.fromAscList [ (x,Map.lookup x termSub) | x <- fvs]) typeSub e  where+--    fvs = Set.toAscList (freeVars e `Set.union` fvmap termSub `Set.union` fvmap typeSub)+--    fvmap m = Set.unions (map freeVars (Map.elems m))+typeSubst' termSub typeSub e = typeSubst  (fmap Just termSub `union` fmap ((`mlookup` termSub) . tvrIdent) fvs) typeSub e  where+    fvs :: IdMap TVr+    fvs = (freeVars e `union` fvmap termSub `union` fvmap typeSub)+    fvmap m = unions (map freeVars (values m))++--substType t e e' = typeSubst (freeVars e `union` freeVars e') (msingleton t e) e'++-- | substitution routine that can substitute different values at the term and type level.+-- this is useful to enforce the invarient that let-bound variables must not occur at the type level, yet+-- non-atomic values (even typelike ones) cannot appear in argument positions at the term level.++typeSubst ::+    IdMap (Maybe E)  -- ^ substitution to carry out at term level as well as a list of in-scope variables+    -> IdMap E       -- ^ substitution to carry out at type level+    -> (E -> E)           -- ^ the substitution function+typeSubst termSubst typeSubst e | isEmpty termSubst && isEmpty typeSubst = e+typeSubst termSubst typeSubst e  = f e (False,termSubst',typeSubst) where+    termSubst' = termSubst `union` fmap (const Nothing) typeSubst+    f :: E -> (Bool,IdMap (Maybe E),IdMap E) -> E+    f eo@(EVar tvr@(TVr { tvrIdent = i, tvrType =  t })) = do+        (wh,trm,tp) <- ask+        case (wh,mlookup i trm, mlookup i tp) of+          (False,(Just (Just v)),_) -> return v+          (True,_,(Just v)) -> return v+          _ -> return eo+    f (ELam tvr e) = lp ELam tvr e+    f (EPi tvr e) = lp EPi tvr e+    f (EAp a b) = liftM2 eAp (f a) (f b)+    f (EError x e) = liftM (EError x) (inType $ f e)+    f (EPrim x es e) = liftM2 (EPrim x) (mapM f es) (inType $ f e)+    f ELetRec { eDefs = dl, eBody = e } = do+        (as,rs) <- liftM unzip $ mapMntvr (fsts dl)+        local (foldr (.) id rs) $ do+            ds <- mapM f (snds dl)+            e' <- f e+            return $ ELetRec (zip as ds) e'+    f (ELit l) = liftM ELit $ litSMapM l+    f Unknown = return Unknown+    f e@(ESort {}) = return e+    f ec@(ECase {}) = do+        e' <- f $ eCaseScrutinee ec+        (b',r) <- ntvr Set.empty $ eCaseBind ec+        d <- local r $ T.mapM f $ eCaseDefault ec+        let da (Alt lc@LitCons { litName = s, litArgs = vs, litType = t } e) = do+                t' <- inType $ f t+                (as,rs) <- liftM unzip $ mapMntvr vs+                e' <- local (foldr (.) id rs) $ f e+                return $ Alt lc { litArgs = as, litType = t' } e'+            da (Alt (LitInt n t) e) = do+                t' <- inType (f t)+                e' <- f e+                return $ Alt (LitInt n t') e'+        alts <- (mapM da $ eCaseAlts ec)+        nty <- inType (f $ eCaseType ec)+        return $ caseUpdate ec { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts, eCaseType = nty }+    lp lam tvr@(TVr { tvrIdent = eid, tvrType = t}) e | eid == emptyId = do+        t' <- inType (f t)+        e' <- f e+        return $ lam (tvr { tvrIdent =  emptyId, tvrType =  t'}) e'+    lp lam tvr e = do+        (tv,r) <- ntvr Set.empty tvr+        e' <- local r $ f e+        return $ lam tv e'+    mapMntvr ts = f ts [] where+        f [] xs = return $ reverse xs+        f (t:ts) rs = do+            (t',r) <- ntvr vs t+            local r $ f ts ((t',r):rs)+        vs = Set.fromList [ tvrIdent x | x <- ts ]+    inType = local (\ (_,trm,typ) -> (True,trm,typ) )+    addMap i (Just e) (b,trm,typ) = (b,minsert i (Just e) trm, minsert i e typ)+    addMap i Nothing (b,trm,typ) = (b,minsert i Nothing trm, typ)+    litSMapM lc@LitCons { litName = s, litArgs = es, litType = t } = do+        t' <- inType $ f t+        es' <- mapM f es+        return $ lc { litArgs = es', litType = t' }+    litSMapM (LitInt n t) = do+        t' <- inType $ f t+        return $ LitInt n t'+    ntvr xs tvr@(TVr { tvrIdent = eid, tvrType =  t}) | eid == emptyId = do+        t' <- inType (f t)+        let nvr = (tvr { tvrType =  t'})+        return (nvr,id)+    ntvr xs tvr@(TVr {tvrIdent = i, tvrType =  t}) = do+        t' <- inType (f t)+        (_,map,_) <- ask+        let i' = mnv False xs i (\_ -> False) Set.empty map+        let nvr = (tvr { tvrIdent =  i', tvrType =  t'})+        case i == i' of+            True -> return (nvr,addMap i  (Just $ EVar nvr))+            False -> return (nvr,addMap i (Just $ EVar nvr) . addMap i' Nothing)
+ src/E/Traverse.hs view
@@ -0,0 +1,183 @@+module E.Traverse(+    emapE_,+    emapE,+    emapE',+    emapEG,+    emapEGH,+    eSize,+    renameE,+    scopeCheck,+    runRename+    ) where++import Control.Monad.Reader+import Control.Monad.Writer.Strict+import Data.Maybe+import qualified Data.Traversable as T++import E.E+import Name.Id+import Util.Gen+import Util.HasSize+import Util.NameMonad+import Util.SetLike as S++-- Generic traversal routines rock.++newtype MInt = MInt Int++instance Monoid MInt where+    mempty = MInt 0+    mappend (MInt a) (MInt b) = a `seq` b `seq` MInt (a + b)++runRename :: IdSet -> E -> (E,IdSet)+runRename set e = renameE set mempty e++emapE_ :: Monad m => (E -> m a) -> E -> m ()+emapE_ f e = emapEG f' f' e >> return () where+    f' e = f e >> return e+emapE f = emapEG f f+emapE' f = emapEG f return++emapEG f g e = emapEGH f g g e++-- map subexpressions+-- emapEGH f g h+-- f - applied to direct subexpressions+-- g - applied to the type-level subexpressions+-- h - applied to the types of variables that occur in value position+emapEGH f g h e = z e where+    z (EAp aa ab) = do aa <- f aa;ab <- f ab; return $ EAp aa ab+    z (ELam aa ab) = do aa <- mapmTvr g aa; ab <- f ab; return $ ELam aa ab+    z (EPi aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ EPi aa ab+    z (EVar aa) = do aa <- mapmTvr h aa; return $ EVar aa+    z (Unknown) = do return $ Unknown+    z (ESort aa) = do return $ ESort aa+    z (ELit lc@LitCons { litArgs = es, litType = t }) = do t' <- g t; es' <- mapM f es; return $ ELit lc { litArgs = es', litType = t' }+    z (ELit aa) = do aa <- T.mapM g aa; return $ ELit aa+    z ELetRec { eDefs = aa, eBody = ab } = do aa <- mapM (\x -> do x <- (do (aa,ab) <- return x; aa <- mapmTvr g aa;ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab+    z ec@ECase {} = do+        e' <- f $ eCaseScrutinee ec+        b' <- T.mapM g (eCaseBind ec)+        as' <- mapM mapmAlt (eCaseAlts ec)+        d' <- T.mapM f (eCaseDefault ec)+        t' <- g (eCaseType ec)+        return $ caseUpdate ec { eCaseScrutinee =e', eCaseBind = b', eCaseAlts = as', eCaseDefault = d', eCaseType = t'}+    --    aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- T.mapM f x; y <- f y; return (x,y)) ab; return $ ECase aa ab+    z (EPrim aa ab ac) = do ab <- mapM f ab;ac <- g ac; return $ EPrim aa ab ac+    z (EError aa ab) = do ab <- g ab; return $ EError aa ab+    mapmTvr = T.mapM+    mapmAlt (Alt lc@LitCons {  litArgs = xs, litType = t } e) = do+        e' <- f e+        xs' <- mapM (T.mapM g) xs+        t' <- g t+        return $ Alt lc { litArgs = xs', litType = t' } e'+    mapmAlt (Alt l e) = do+        e' <- f e+        l' <- T.mapM g l+        return (Alt l' e')++instance HasSize E where+    size = eSize++eSize :: E -> Int+eSize e = n where+    (_, MInt n) = runWriter (f e)+    f e@ELit {} = tell (MInt 1) >> return e+    f e@EPrim {} = tell (MInt 1) >> return e+    f e@EError {} = tell (MInt 1) >> return e+    f e = tell (MInt 1) >> emapE' f e++renameE :: IdSet -> IdMap E -> E -> (E,IdSet)+renameE initSet initMap e = runReader (runIdNameT $ addBoundNamesIdMap initMap >> addBoundNamesIdSet initSet >> f e) initMap  where+    f,f' :: E -> IdNameT (Reader (IdMap E)) E+    f' e = f e+    f  (EAp a b) = return EAp `ap` f a `ap` f b+    f  (ELit lc@LitCons { litArgs = xs, litType = t }) = do+        xs' <- mapM f xs+        t' <- f' t+        return $ ELit lc { litArgs = xs', litType = t' }+    f (ELit (LitInt n t)) = do+        t' <- f' t+        return (ELit (LitInt n t'))+    f (EError x t) = return (EError x) `ap` f' t+    f (EPrim n es t) = do+        es' <- mapM f es+        t' <- f' t+        return $ EPrim n es' t'+    f (ELam tvr e) = lp f' ELam tvr e+    f (EPi tvr e) = lp f EPi tvr e+    f  e@(EVar TVr { tvrIdent = n }) = do+        im <- lift ask+        case mlookup n im of+            Just n' -> do return n'+            Nothing -> return e+    f x@(ESort {}) = return x+    f Unknown = return Unknown+    f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } = do+        e' <- f e+        t' <- f' (eCaseType ec)+        addNames $ map tvrIdent (caseBinds ec)+        (ob,b') <- ntvr False f' b+        localSubst ob $ do+            as' <- mapM da as+            d' <- T.mapM f d+            return $ caseUpdate ec { eCaseScrutinee = e', eCaseType = t', eCaseBind = b', eCaseAlts = as', eCaseDefault = d' }+    f ELetRec { eDefs = ds, eBody = e } = do+        addNames (map (tvrIdent . fst) ds)+        ds' <- mapM ( ntvr False f' . fst) ds+        localSubst (mconcat $ fsts ds') $ do+            es <- mapM f (snds ds)+            e' <- f e+            return (ELetRec (zip (snds ds') es) e')+    --f e = error $ "renameE.f: " ++ show e+    da :: Alt E -> IdNameT (Reader (IdMap E)) (Alt E)+    da (Alt lc@LitCons { litName = n, litArgs = xs, litType = t } l) = do+        t' <- f' t+        xs' <-  mapM (ntvr False f') xs+        localSubst (mconcat [ x | (x,_) <- xs']) $ do+            l' <- f l+            return (Alt lc { litArgs = snds xs', litType = t' } l')+    da (Alt (LitInt n t) l) = do+        t' <- f' t+        l' <- f l+        return (Alt (LitInt n t') l')+    localSubst :: (IdMap E) -> IdNameT (Reader (IdMap E)) a  -> IdNameT (Reader (IdMap E)) a+    localSubst ex action = do local (ex `mappend`) action+    ntvr _ fg tv@TVr { tvrIdent = eid, tvrType = t} | eid == emptyId = do+        t' <- fg t+        return (mempty,tv { tvrType = t'})+    ntvr ralways fg tv@(TVr { tvrIdent = n, tvrType = t}) = do+        --n' <- if n > 0 && (not ralways || isValidAtom n) then uniqueName  n else newName+        n' <- if not (isEtherealId n) && (not ralways || isJust (fromId n)) then uniqueName  n else newName+        --n' <- if (not ralways || isValidAtom n) then uniqueName  n else newName+        t' <- fg t+        let tv' = tv { tvrIdent = n', tvrType = t' }+        return (msingleton n (EVar tv'),tv')+    lp fg elam tv e = do+        (n,tv') <- ntvr True fg tv+        e' <- localSubst n (f e)+        return $ elam tv' e'++scopeCheck :: Monad m => Bool -> IdMap TVr -> E -> m ()+scopeCheck checkFvs initMap e = runReaderT (f e) initMap  where+    f (ELam tvr e) = f (tvrType tvr) >> local (minsert (tvrIdent tvr) tvr) (f e)+    f (EPi tvr e) = f (tvrType tvr) >> local (minsert (tvrIdent tvr) tvr) (f e)+    f (EVar t) = do+        m <- ask+        case mlookup (tvrIdent t) m of+            Nothing | checkFvs -> fail $ "scopeCheck: found variable not in scope " ++ tvrShowName t+            Just t' | tvrType t /= tvrType t' -> fail $ "scopeCheck: found variable whose type does not match " ++ tvrShowName t+            _ -> return ()+    f ec@ECase { eCaseBind = b } = do+        f (eCaseScrutinee ec)+        f (eCaseType ec)+        f (tvrType b)+        local (minsert (tvrIdent b) b) $ mapM_ doAlt (eCaseAlts ec)+    f ELetRec { eDefs = ds, eBody = e } = do+        mapM_ (f . tvrType . fst) ds+        local (fromList [ (tvrIdent t,t) | (t,_) <- ds ] `mappend`) (f e)+    f e = emapE_ f e+    doAlt (Alt LitCons { litArgs = xs, litType = t } e) = do+        f t >> local (fromList [ (tvrIdent t,t) | t <- xs] `mappend`) (f e)+    doAlt (Alt (LitInt _ t) e) = f t >> f e
+ src/E/TypeAnalysis.hs view
@@ -0,0 +1,403 @@+-- | examine all uses of types in a program to determine which ones are+-- actually needed in the method generation++module E.TypeAnalysis(typeAnalyze, Typ(),expandPlaceholder) where++import Control.Monad.Error+import Control.Monad.Identity+import Control.Monad.State+import Data.Maybe+import Data.Monoid+import qualified Data.Foldable as T+import qualified Data.Map as Map+import qualified Data.Set as Set++import DataConstructors+import Doc.PPrint+import E.Annotate+import E.E hiding(isBottom)+import E.Eta+import E.Program+import E.Rules+import E.Subst+import E.Traverse(emapE',emapE_,emapE)+import E.TypeCheck+import E.Values+import Fixer.Fixer+import Fixer.Supply+import Fixer.VMap+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import Support.CanType+import Util.Gen+import Util.SetLike hiding(Value)+import qualified Info.Info as Info+import qualified Stats++type Typ = VMap () Name+data Env = Env {+    envRuleSupply :: Supply (Module,Int) Bool,+    envValSupply  :: Supply TVr Bool,+    envEnv        :: IdMap [Value Typ]+    }++extractValMap :: [(TVr,E)] -> IdMap [Value Typ]+extractValMap ds = fromList [ (tvrIdent t,f e []) | (t,e) <- ds] where+    f (ELam tvr e) rs | sortKindLike (getType tvr) = f e (runIdentity (Info.lookup $ tvrInfo tvr):rs)+    f _ rs = reverse rs++-- all variables _must_ be unique before running this+{-# NOINLINE typeAnalyze #-}+typeAnalyze :: Bool -> Program -> IO Program+typeAnalyze doSpecialize prog = do+    fixer <- newFixer+    ur <- newSupply fixer+    uv <- newSupply fixer+    let lambind _ nfo = do+            x <- newValue fixer ( bottom :: Typ)+            return $ Info.insert x (Info.delete (undefined :: Typ) nfo)+    prog <- annotateProgram mempty lambind (\_ -> return . deleteArity) (\_ -> return) prog+    let ds = programDs prog+        env = Env { envRuleSupply = ur, envValSupply = uv, envEnv = extractValMap ds }+        entries = progEntryPoints prog+    calcCombs env $ progCombinators prog+    forM_ entries $ \tvr ->  do+        vv <- supplyValue uv tvr+        addRule $ assert vv+    mapM_ (sillyEntry env) entries+    findFixpoint Nothing fixer+    let lamread _ nfo | Just v <- Info.lookup nfo = do+            rv <- readValue v+            return (Info.insert (rv :: Typ) $ Info.delete (undefined :: Value Typ) nfo)+        lamread _ nfo = return nfo+    prog <- annotateProgram mempty lamread (\_ -> return) (\_ -> return) prog+    unusedRules <- supplyReadValues ur >>= return . fsts . filter (not . snd)+    unusedValues <- supplyReadValues uv >>= return . fsts . filter (not . snd)+    let (prog',stats) = Stats.runStatM $ specializeProgram doSpecialize (fromList unusedRules) (fromList unusedValues) prog+    let lamdel _ nfo = return (Info.delete (undefined :: Value Typ) nfo)+    prog <- annotateProgram mempty lamdel (\_ -> return) (\_ -> return) prog'+    return prog { progStats = progStats prog `mappend` stats }++sillyEntry :: Env -> TVr -> IO ()+sillyEntry env t = mapM_ (addRule . (`isSuperSetOf` value (vmapPlaceholder ()))) args where+    args = lookupArgs t env++lookupArgs t Env { envEnv = tm }  = maybe [] id (mlookup (tvrIdent t) tm)++toLit (EPi TVr { tvrType = a } b) = return (tc_Arrow,[a,b])+toLit (ELit LitCons { litName = n, litArgs = ts }) = return (n,ts)+toLit _ = fail "not convertable to literal"++assert :: Value Bool -> Fixer.Fixer.Rule+assert v = v `isSuperSetOf` value True++calcComb :: Env -> Comb -> IO ()+calcComb env@Env { envRuleSupply = ur, envValSupply = uv } comb = do+    let (_,ls) = fromLam $ combBody comb+        tls = takeWhile (sortKindLike . getType) ls+        rs = combRules comb+        t = combHead comb+        hr r = do+            ruleUsed <- supplyValue ur (ruleUniq r)+            addRule $ conditionalRule id ruleUsed (ioToRule $  calcE env (ruleBody r))+            let hrg r (t,EVar a) | a `elem` ruleBinds r = do+                    let (t'::Value Typ) = Info.fetch (tvrInfo t)+                    let (a'::Value Typ) = Info.fetch (tvrInfo a)+                    addRule $ conditionalRule id ruleUsed $ ioToRule $ do+                        addRule $ a' `isSuperSetOf` t'+                    return True+                hrg r (t,e) | Just (n,as) <- toLit e = do+                    let (t'::Value Typ) = Info.fetch (tvrInfo t)+                    as' <- mapM getValue as+                    addRule $ conditionalRule id ruleUsed $ ioToRule $ do+                        forMn_ ((zip as as')) $ \ ((a',a''),i) -> do+                            when (isEVar a') $ addRule $ modifiedSuperSetOf a'' t' (vmapArg n i)+                    addRule $ conditionalRule (n `vmapMember`) t' (assert ruleUsed)+                    return False+                hrg x y = error $ "TypeAnalyis.hrg: " ++ show (x,y)+            rr <- mapM (hrg r) (zip tls (ruleArgs r))+            when (and rr) $ addRule (assert ruleUsed)+    valUsed <- supplyValue uv t+    addRule $ conditionalRule id valUsed $ ioToRule $ do+        mapM_ hr rs+        calcE env $ combBody comb++calcDef :: Env -> (TVr,E) -> IO ()+calcDef env@Env { envValSupply = uv } (t,e) = do+    valUsed <- supplyValue uv t+    addRule $ conditionalRule id valUsed $ ioToRule $ do+        calcE env e++calcCombs ::  Env -> [Comb] -> IO ()+calcCombs env@Env { envRuleSupply = ur, envValSupply = uv } ds = do+    mapM_ (calcTE env) [ (combHead c,combBody c) | c <- ds ]+    mapM_ (calcComb env) ds++calcTE ::  Env -> (TVr,E) -> IO ()+calcTE env@Env { envRuleSupply = ur, envValSupply = uv } ds = d ds where+    d (t,e) | not (sortKindLike (getType t)) = return ()+    d (t,e) | Just v <- getValue e = do+        let Just t' = Info.lookup (tvrInfo t)+        addRule $ t' `isSuperSetOf` v+    d (t,e) | Just (n,xs) <- toLit e = do+        let Just t' = Info.lookup (tvrInfo t)+            v = vmapSingleton n+        addRule $ t' `isSuperSetOf` (value v)+        xs' <- mapM getValue xs+        forMn_ xs' $ \ (v,i) -> do+            addRule $ modifiedSuperSetOf t' v (vmapArgSingleton n i)+    d (t,e) | (EVar v,as) <- fromAp e = do+        let Just t' = Info.lookup (tvrInfo t)+            Just v' = Info.lookup (tvrInfo v)+        as' <- mapM getValue as+        addRule $ dynamicRule v' $ \ v -> mconcat $ (t' `isSuperSetOf` value (vmapDropArgs v)):case vmapHeads v of+                Just vs -> concat $ flip map vs $ \h -> (flip map (zip as' [0.. ])  $ \ (a,i) -> modifiedSuperSetOf t' a $ \ v -> vmapArgSingleton h i v)+                Nothing -> flip map (zip as' [0.. ])  $ \ (_,i) -> isSuperSetOf t' (value $ vmapProxyIndirect i v)+    d (t,e) = fail $ "calcDs: " ++ show (t,e)++calcDs ::  Env -> [(TVr,E)] -> IO ()+calcDs env@Env { envRuleSupply = ur, envValSupply = uv } ds = do+    mapM_ (calcTE env) ds+    forM_ ds $ \ (v,e) -> do calcDef env (v,e)++-- TODO - make default case conditional+calcAlt env v (Alt ~LitCons { litName = n, litArgs = xs } e) = do+    addRule $ conditionalRule (n `vmapMember`) v $ ioToRule $ do+        calcE env e+        forMn_ xs $ \ (t,i) -> do+            let Just t' = Info.lookup (tvrInfo t)+            addRule $ modifiedSuperSetOf t' v (vmapArg n i)++calcE :: Env -> E -> IO ()+calcE env (ELetRec ds e) = calcDs nenv ds >> calcE nenv e where+    nenv = env { envEnv = extractValMap ds `union` envEnv env }+calcE env ec@ECase {} | sortKindLike (getType $ eCaseScrutinee ec) = do+    calcE env (eCaseScrutinee ec)+    T.mapM_ (calcE env) (eCaseDefault ec)+    v <- getValue (eCaseScrutinee ec)+    mapM_ (calcAlt env v) (eCaseAlts ec)+calcE env e | (e',(_:_)) <- fromLam e = calcE env e'+calcE env ec@ECase {} = do+    calcE env (eCaseScrutinee ec)+    mapM_ (calcE env) (caseBodies ec)+calcE env e@ELit {} = tagE env e+calcE env e@EPrim {} = tagE env e+calcE _ EError {} = return ()+calcE _ ESort {} = return ()+calcE _ Unknown = return ()+calcE env e | (EVar v,as@(_:_)) <- fromAp e = do+    let ts = lookupArgs v env+    tagE env e+    when (length as < length ts) $ fail ("calcE: unsaturated call to function: " ++ pprint e)+    forM_ (zip as ts) $ \ (a,t) -> do+        when (sortKindLike (getType a)) $ do+            a' <- getValue a+            addRule $ t `isSuperSetOf` a'+calcE env e@EVar {} = tagE env e+calcE env e@EAp {} = tagE env e+calcE env e@EPi {} = tagE env e+calcE _ e = fail $ "odd calcE: " ++ show e++tagE Env { envValSupply = uv }  (EVar v) | not $ getProperty prop_RULEBINDER v = do+    v <- supplyValue uv v+    addRule $ assert v+tagE env e  = emapE_ (tagE env) e++getValue (EVar v)+    | Just x <- Info.lookup (tvrInfo v) = return x+    | otherwise = return $ value (vmapPlaceholder ())+    -- | otherwise = fail $ "getValue: no varinfo: " ++ show v+getValue e | Just c <- typConstant e = return $ value c+getValue e = return $ value $ fuzzyConstant e -- TODO - make more accurate++fuzzyConstant :: E -> Typ+fuzzyConstant e | Just (n,as) <- toLit e = vmapValue n (map fuzzyConstant as)+fuzzyConstant _ = vmapPlaceholder ()++typConstant :: Monad m => E -> m Typ+typConstant e | Just (n,as) <- toLit e = return (vmapValue n) `ap` mapM typConstant as+typConstant e = fail $ "typConstant: " ++ show e++data SpecEnv = SpecEnv {+    senvUnusedRules :: Set.Set (Module,Int),+    senvUnusedVars  :: Set.Set TVr,+    senvDataTable :: DataTable,+    senvArgs      :: Map.Map TVr [Int]+    }++getTyp :: Monad m => E -> DataTable -> Typ -> m E+getTyp kind dataTable vm = f (10::Int) kind vm where+    f n _ _ | n <= 0 = fail "getTyp: too deep"+    f n kind vm | Just [] <- vmapHeads vm = return $ tAbsurd kind+    f n kind vm | Just [h] <- vmapHeads vm = do+        let ss = slotTypes dataTable h kind+            as = [ (s,vmapArg h i vm) | (s,i) <- zip ss [0..]]+        as'@(~[fa,fb]) <- mapM (uncurry (f (n - 1))) as+        if h == tc_Arrow+         then return $ EPi tvr { tvrType = fa } fb+         else return $ ELit (updateLit dataTable litCons { litName = h, litArgs = as', litType = kind })+    f _ _ _  = fail "getTyp: not constant type"++specializeProgram :: (Stats.MonadStats m) =>+    Bool                       -- ^ do specialization+    -> (Set.Set (Module,Int))  -- ^ unused rules+    -> (Set.Set TVr)           -- ^ unused values+    -> Program+    -> m Program+specializeProgram doSpecialize unusedRules unusedValues prog = do+    (nds,_) <- specializeCombs doSpecialize SpecEnv+        { senvUnusedRules = unusedRules+        , senvUnusedVars = unusedValues+        , senvDataTable = progDataTable prog+        , senvArgs = mempty } (progCombinators prog)+    return $ progCombinators_s nds prog++repi (ELit LitCons { litName = n, litArgs = [a,b] }) | n == tc_Arrow = EPi tvr { tvrIdent = emptyId, tvrType = repi a } (repi b)+repi e = runIdentity $ emapE (return . repi ) e++specializeComb _ env  comb | isUnused env (combHead comb) = let tvr = combHead comb in+    return (combRules_s [] . combBody_s (EError ("Unused Def: " ++ tvrShowName tvr) (tvrType tvr)) $ comb , mempty)+specializeComb _ _ comb | getProperty prop_PLACEHOLDER comb = return (comb, mempty)+specializeComb True SpecEnv { senvDataTable = dataTable }  comb | needsSpec = ans where+    tvr = combHead comb+    e = combBody comb+    sub = substMap'  $ fromList [ (tvrIdent t,v) | (t,Just v) <- sts ]+    sts = map spec ts+    spec t | Just nt <- Info.lookup (tvrInfo t) >>= getTyp (getType t) dataTable, sortKindLike (getType t) = (t,Just (repi nt))+    spec t = (t,Nothing)+    (fe,ts) = fromLam e+    ne = sub $ foldr ELam fe [ t | (t,Nothing) <- sts]+    vs = [ (n,v) | ((_,Just v),n) <- zip sts naturals ]+    needsSpec = not $ null vs+    ans = do+        sequence_ [ Stats.mtick ("Specialize.body.{" ++ pprint tvr ++ "}.{" ++ pprint t ++ "}.{" ++ pprint v) | (t,Just v) <- sts ]+        let nc  = combHead_s tvr { tvrType = infertype dataTable ne }+                . combBody_s ne+                . combRules_u (dropArguments vs)+                $ comb+        return (nc,msingleton tvr (fsts vs))+specializeComb _ _ comb = return (comb,mempty)++instance Error () where+    noMsg = ()+    strMsg _ = ()++evalErrorT :: Monad m => a -> ErrorT () m a -> m a+evalErrorT err action = liftM f (runErrorT action) where+    f (Left _) = err+    f (Right x) = x++eToPatM :: Monad m => (E -> m TVr) -> E -> m (Lit TVr E)+eToPatM cv e = f e where+    f (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = do+        ts <- mapM cv ts+        return litCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }+    f (ELit (LitInt e t)) = return (LitInt e t)+    f (EPi (TVr { tvrType =  a}) b)  = do+        a <- cv a+        b <- cv b+        return litCons { litName = tc_Arrow, litArgs = [a,b], litType = eStar }+    f x = fail $ "E.Values.eToPatM: " ++ show x++caseCast :: TVr -> E -> E -> E+caseCast t ty e = evalState  (f t ty e) (newIds (freeIds e),[]) where+--    f t ty e | isFullyConst ty = return $+--        prim_unsafeCoerce (subst t ty e) (getType e)+    f t ty e = do+        p <- eToPatM cv ty+        (ns,es) <- get+        put (ns,[])+        let rs = map (uncurry caseCast) es+        return (eCase (EVar t) [Alt p (foldr (.) id rs e)] Unknown)+    cv (EVar v) = return v+    cv e = do+        ((n:ns),es) <- get+        let t = tvr { tvrIdent = n, tvrType = getType e }+        put (ns,(t,e):es)+        return t++specAlt :: Stats.MonadStats m => SpecEnv -> Alt E -> m (Alt E)+specAlt env@SpecEnv { senvDataTable = dataTable } (Alt ~lc@LitCons { litArgs = ts } e) = ans where+    f xs = do+        ws <- forM xs $ \t -> evalErrorT id $ do+            False <- return $ isUnused env t+            Just nt <- return $ Info.lookup (tvrInfo t)+            Just tt <- return $ getTyp (getType t) dataTable nt+            Stats.mtick $ "Specialize.alt.{" ++ pprint (show nt,tt) ++ "}"+            return $ caseCast t tt+        return $ foldr (.) id ws+    ans = do+        ws <- f ts+        return (Alt lc (ws e))++isUnused SpecEnv { senvUnusedVars = unusedVars } v =+    v `member` unusedVars && isJust (Info.lookup $ tvrInfo v :: Maybe Typ)++specBody :: Stats.MonadStats m => Bool -> SpecEnv -> E -> m E+--specBody _ env e | (EVar h,as) <- fromAp e, isUnused env h  = do+--    Stats.mtick $ "Specialize.delete.{" ++ pprint h ++ "}"+--    return $ foldl EAp (EError ("Unused: " ++ pprint h) (getType h)) as+specBody True env@SpecEnv { senvArgs = dmap } e | (EVar h,as) <- fromAp e, Just os <- mlookup h dmap = do+    Stats.mtick $ "Specialize.use.{" ++ pprint h ++ "}"+    as' <- mapM (specBody True env) as+    return $ foldl EAp (EVar h) [ a | (a,i) <- zip as' naturals, i `notElem` os ]+specBody True env ec@ECase { eCaseScrutinee = EVar v } | sortKindLike (getType v) = do+    alts <- mapM (specAlt env) (eCaseAlts ec)+    emapE' (specBody True env) ec { eCaseAlts = alts }+specBody doSpecialize env (ELetRec ds e) = do+    (nds,nenv) <- specializeDs doSpecialize env ds+    e <- specBody doSpecialize nenv e+    return $ ELetRec nds e+specBody doSpecialize env e = emapE' (specBody doSpecialize env) e++--specializeDs :: MonadStats m => DataTable -> Map.Map TVr [Int] -> [(TVr,E)] -> m ([(TVr,E)]+specializeDs doSpecialize env@SpecEnv { senvUnusedRules = unusedRules, senvDataTable = dataTable } ds = do+    (ds,nenv) <- mapAndUnzipM (specializeComb doSpecialize env) (map bindComb ds)+    ds <- return $ map combBind ds+    let tenv = env { senvArgs = unions nenv `union` senvArgs env }+        sb = specBody doSpecialize tenv+    let f (t,e) = do+            e <- sb e+            return (t,e)+    ds <- mapM f ds+    return (ds,tenv)++--specializeDs :: MonadStats m => DataTable -> Map.Map TVr [Int] -> [(TVr,E)] -> m ([(TVr,E)]+specializeCombs doSpecialize env@SpecEnv { senvUnusedRules = unusedRules, senvDataTable = dataTable } ds = do+    (ds,nenv) <- mapAndUnzipM (specializeComb doSpecialize env) ds+    let tenv = env { senvArgs = unions nenv `union` senvArgs env }+        sb = specBody doSpecialize tenv+    let f comb = do+            e <- sb (combBody comb)+            rs <- mapM (mapRBodyArgs sb) (combRules comb)+            let rs' =  filter ( not . (`member` unusedRules) . ruleUniq) rs+            return . combBody_s e . combRules_s rs' $ comb+    ds <- mapM f ds+    return (ds,tenv)++expandPlaceholder :: Monad m => Comb -> m Comb+expandPlaceholder comb  | getProperty prop_PLACEHOLDER (combHead comb) = do+    let rules = filter isBodyRule $  combRules comb+        tvr = combHead comb+        isBodyRule Rule { ruleType = RuleSpecialization } = True+        isBodyRule _ = False+    let mcomb nb = (combBody_s nb  . combHead_u (unsetProperty prop_PLACEHOLDER) $ comb)+    if null rules then return (mcomb $  EError ("Placeholder, no bodies: " ++ tvrShowName tvr) (getType tvr)) else do+    let (oe',as) = fromLam $ combBody comb+        rule1:_ = rules+        ct = getType $ foldr ELam oe' (drop (length $ ruleArgs rule1) as)+        as'@(a:ras)+                | (a:ras) <- take (length $ ruleArgs rule1) as = (a:ras)+                | otherwise = error $ pprint (tvr,(combBody comb,show rule1))+        ne = emptyCase {+            eCaseScrutinee = EVar a,+            eCaseAlts = map calt rules,+            eCaseBind = a { tvrIdent = emptyId },+            eCaseType = ct+            }+        calt rule@Rule { ruleArgs = ~(arg:rs) } = Alt vp (substMap (fromList [ (tvrIdent v,EVar r) | ~(EVar v) <- rs | r <- ras ]) $ ruleBody rule) where+            Just vp = eToPat arg+    return (mcomb (foldr ELam ne as'))+expandPlaceholder _x = fail "not placeholder"
+ src/E/Values.hs view
@@ -0,0 +1,276 @@+module E.Values where++import Control.Monad.Identity+import Data.Monoid+import Data.List+import Data.Ratio++import C.Prims+import E.E+import E.FreeVars()+import E.Subst+import E.TypeCheck+import Info.Info(HasInfo(..))+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import Name.VConsts+import Support.CanType+import Support.FreeVars+import Support.Tuple+import Util.SetLike+import qualified Info.Info as Info++instance Tuple E where+    tupleNil = vUnit+    tupleMany es = ELit litCons { litName = nameTuple DataConstructor (length es), litArgs = es, litType = ltTuple ts } where+        ts = map getType es++eTuple :: [E] -> E+eTuple = tuple++eTuple' es = ELit $ unboxedTuple es++unboxedTuple es =  litCons { litName = unboxedNameTuple DataConstructor (length es), litArgs = es, litType = ltTuple' ts } where+    ts = map getType es++unboxedUnit :: E+unboxedUnit =  ELit $ unboxedTuple []++unboxedTyUnit :: E+unboxedTyUnit = ltTuple' []++class ToE a where+    toE :: a -> E+    typeE :: a -> E -- lazy in a++class ToEzh a where+    toEzh :: a -> E+    typeEzh :: a -> E++instance ToEzh Char where+    toEzh ch = ELit $ LitInt (fromIntegral $ fromEnum ch) tCharzh+    typeEzh _ = tCharzh++instance ToEzh Int where+    toEzh ch = ELit $ LitInt (fromIntegral  ch) tIntzh+    typeEzh _ = tIntzh++instance ToEzh Integer where+    toEzh ch = ELit $ LitInt (fromIntegral  ch) tIntegerzh+    typeEzh _ = tIntegerzh++instance ToE () where+    toE () = vUnit+    typeE _ = tUnit++instance ToE Bool where+    toE True = vTrue+    toE False = vFalse+    typeE _ = tBool++instance ToE Char where+    toE ch = ELit (litCons { litName = dc_Char, litArgs = [toEzh ch], litType = tChar })+    typeE _ = tChar++instance ToE Rational where+    toE rat = ELit (litCons { litName = dc_Ratio, litArgs = [toE (numerator rat), toE (denominator rat)], litType = tRational })+    typeE _ = tRational++instance ToE Integer where+    toE ch = ELit (litCons { litName = dc_Integer, litArgs = [toEzh ch], litType = tInteger })+    typeE _ = tInteger++instance ToE Int where+    toE ch = ELit (litCons { litName = dc_Int, litArgs = [toEzh ch], litType = tInt })+    typeE _ = tInt++instance ToE a => ToE [a] where+    toE xs@[] = eNil (typeE xs)+    toE (x:xs) = eCons (toE x) (toE xs)+    typeE (_::[a]) = ELit (litCons { litName = tc_List, litArgs = [typeE (undefined::a)], litType = eStar })++--eInt x = ELit $ LitInt x tInt++eCons x xs = ELit $ litCons { litName = dc_Cons, litArgs = [x,xs], litType = getType xs }+eNil t = ELit $ litCons { litName = dc_EmptyList, litArgs = [], litType = t }++emptyCase = ECase {+    eCaseAllFV = mempty,+    eCaseDefault = Nothing,+    eCaseAlts = [],+    eCaseBind = error "emptyCase: bind",+    eCaseType = error "emptyCase: type",+    eCaseScrutinee = error "emptyCase: scrutinee"+    }++eCaseTup e vs w = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind =  (tVr emptyId (getType e)), eCaseType = getType w, eCaseAlts =  [Alt litCons { litName = nameTuple DataConstructor (length vs), litArgs = vs, litType = getType e } w] }+eCaseTup' e vs w = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseType = getType w, eCaseAlts =  [Alt litCons { litName = unboxedNameTuple DataConstructor (length vs), litArgs = vs, litType = getType e} w] }++eJustIO w x = eTuple' [w,x]++eCase e alts@(alt:_) Unknown = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseType = getType alt,  eCaseAlts =  alts }+eCase e alts els = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseDefault = Just els, eCaseAlts =  alts, eCaseType = getType els }++-- | This takes care of types right away, it simplifies various other things to do it this way.+eLet :: TVr -> E -> E -> E+eLet TVr { tvrIdent = eid } _ e' | eid == emptyId = e'+eLet t@(TVr { tvrType =  ty}) e e'+    | sortKindLike ty && isAtomic e = subst t e e'+    | sortKindLike ty = ELetRec [(t,e)] (typeSubst mempty (msingleton (tvrIdent t) e) e')+    | isUnboxed ty && isAtomic e = subst t e e'+    | isUnboxed ty  = eStrictLet t e e'+eLet t e e' = ELetRec [(t,e)] e'++-- | strict version of let, evaluates argument before assigning it.+eStrictLet t@(TVr { tvrType =  ty }) v e | sortKindLike ty  = eLet t v e+eStrictLet t v e = caseUpdate emptyCase { eCaseScrutinee = v, eCaseBind = t, eCaseDefault = Just e, eCaseType = getType e }++substLet :: [(TVr,E)] -> E -> E+substLet ds e  = ans where+    (as,nas) = partition (isAtomic . snd) (filter ((/= emptyId) . tvrIdent . fst) ds)+    tas = filter (sortKindLike . tvrType . fst) nas+    ans = eLetRec (as ++ nas) (typeSubst' (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- as]) (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas]) e)++substLet' :: [(TVr,E)] -> E -> E+substLet' ds' e  = ans where+    (hh,ds) = partition (isUnboxed . tvrType . fst) ds'+    nas = filter ((/= emptyId) . tvrIdent . fst) ds+    tas = filter (sortKindLike . tvrType . fst) nas+    ans = case (nas,tas) of+        ([],_) -> hhh hh $ e+        (nas,[]) -> hhh hh $ ELetRec nas e+        _  -> let+                    f = typeSubst' mempty (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas])+                    nas' = [ (v,f e) | (v,e) <- nas]+               in hhh hh $ ELetRec nas' (f e)+    hhh [] e = e+    hhh ((h,v):hh) e = eLet h v (hhh hh e)++eLetRec = substLet'++prim_seq a b | isWHNF a = b+prim_seq a b = caseUpdate emptyCase { eCaseScrutinee = a, eCaseBind =  (tVr emptyId (getType a)), eCaseDefault = Just b, eCaseType = getType b }++prim_unsafeCoerce e t = p e' where+    (_,e',p) = unsafeCoerceOpt $ EPrim p_unsafeCoerce [e] t+from_unsafeCoerce (EPrim pp [e] t) | pp == p_unsafeCoerce = return (e,t)+from_unsafeCoerce _ = fail "Not unsafeCoerce primitive"++isState_ e = case e of+    ELit (LitCons { litName = name }) | name == tc_State_ -> True+    _ -> False++unsafeCoerceOpt (EPrim uc [e] t) | uc == p_unsafeCoerce = f (0::Int) e t where+    f n e t | Just (e',_) <- from_unsafeCoerce e = f (n + 1) e' t+    f n (ELetRec ds e) t = (n + 1, ELetRec ds (p e'),id) where+        (n,e',p) = f n e t+    f n (EError err _) t = (n,EError err t,id)+    f n (ELit (LitInt x _)) t = (n,ELit (LitInt x t),id)+    f n (ELit lc@LitCons {}) t = (n,ELit lc { litType = t },id)+    f n ec@ECase {} t = (n,caseUpdate nx { eCaseType = t },id) where+        Identity nx = caseBodiesMapM (return . flip prim_unsafeCoerce t) ec+    f n e t | getType e == t = (n,e,id)+    f n e t = (n,e,\z -> EPrim p_unsafeCoerce [z] t)+unsafeCoerceOpt e = (0,e,id)++instance HasInfo TVr where+    getInfo = tvrInfo+    modifyInfo = tvrInfo_u++-- various routines used to classify expressions+-- many assume atomicity constraints are in place++-- | whether a value is a compile time constant+isFullyConst :: E -> Bool+isFullyConst (ELit LitCons { litArgs = [] }) = True+isFullyConst (ELit LitCons { litArgs = xs }) = all isFullyConst xs+isFullyConst ELit {} = True+isFullyConst (EPi (TVr { tvrType = t }) x) =  isFullyConst t && isFullyConst x+isFullyConst (EPrim p as _) = primIsConstant p && all isFullyConst as+isFullyConst _ = False++-- | whether a value may be used as an argument to an application, literal, or primitive+-- these may be duplicated with no code size or runtime penalty+isAtomic :: E -> Bool+isAtomic EVar {}  = True+isAtomic e | sortTypeLike e = True+isAtomic (EPrim don [x,y] _) | don == p_dependingOn = isAtomic x+isAtomic e = isFullyConst e++-- | whether a type is "obviously" atomic. fast and lazy, doesn't recurse+-- True -> definitely atomic+-- False -> maybe atomic+isManifestAtomic :: E -> Bool+isManifestAtomic EVar {}  = True+isManifestAtomic (ELit LitInt {})  = True+isManifestAtomic (ELit LitCons { litArgs = []})  = True+isManifestAtomic _ = False++-- | whether an expression is small enough that it can be duplicated without code size growing too much. (work may be repeated)+isSmall e | isAtomic e = True+isSmall ELit {} = True+isSmall EPrim {} = True+isSmall EError {} = True+isSmall e | (EVar _,xs) <- fromAp e = length xs <= 4+isSmall _ = False++-- | whether an expression may be duplicated or pushed inside a lambda without duplicating too much work++isCheap :: E -> Bool+isCheap EError {} = True+isCheap ELit {} = True+isCheap EPi {} = True+isCheap ELam {} = True -- should exclude values dropped at compile time+isCheap x | isAtomic x = True+isCheap (EPrim p _ _) = primIsCheap p+isCheap ec@ECase {} = isCheap (eCaseScrutinee ec) && all isCheap (caseBodies ec)+isCheap e | (EVar v,xs) <- fromAp e, Just (Arity n b) <- Info.lookup (tvrInfo v) =+        (length xs < n)  -- Partial applications are cheap+          || (b && length xs >= n) -- bottoming out routines are cheap+isCheap _ = False++-- | determine if term can contain _|_+isLifted :: E -> Bool+isLifted x = sortTermLike x && not (isUnboxed (getType x))++-- Note: This does not treat lambdas as whnf+whnfOrBot :: E -> Bool+whnfOrBot (EError {}) = True+whnfOrBot (ELit LitCons { litArgs = xs }) = all isAtomic xs+whnfOrBot (EPi (TVr { tvrIdent =  j, tvrType =  x }) y) | not (j `member` (freeVars y :: IdSet)) = isAtomic x && isAtomic y+whnfOrBot ELam {} = True+whnfOrBot e | isAtomic e = True+whnfOrBot e | (EVar v,xs) <- fromAp e, Just (Arity n True) <- Info.lookup (tvrInfo v), length xs >= n = True+whnfOrBot _ = False++-- Determine if a type represents an unboxed value+isUnboxed :: E -> Bool+isUnboxed e@EPi {} = False+isUnboxed e = getType e == eHash++safeToDup ec@ECase {}+    | EVar _ <- eCaseScrutinee ec = all safeToDup (caseBodies ec)+    | EPrim p _ _ <- eCaseScrutinee ec, primIsCheap p = all safeToDup (caseBodies ec)+safeToDup (EPrim p _ _) = primIsCheap p+safeToDup e = whnfOrBot e || isELam e || isEPi e++eToPat e = f e where+    f (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = do+        ts <- mapM cv ts+        return litCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }+    f (ELit (LitInt e t)) = return (LitInt e t)+    f (EPi (TVr { tvrType =  a}) b)  = do+        a <- cv a+        b <- cv b+        return litCons { litName = tc_Arrow, litArgs = [a,b], litType = eStar }+    f x = fail $ "E.Values.eToPat: " ++ show x+    cv (EVar v) = return v+    cv e = fail $ "E.Value.eToPat.cv: " ++ show e++patToE p = f p where+    f LitCons { litName = arr, litArgs = [a,b], litType = t} | t == eStar = return $ EPi tvr { tvrType = EVar a } (EVar b)+    f (LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = do+       return $  ELit litCons { litAliasFor = af, litName = x, litArgs = map EVar ts, litType = t }+    f (LitInt e t) = return $ ELit (LitInt e t)
+ src/E/WorkerWrapper.hs view
@@ -0,0 +1,158 @@+module E.WorkerWrapper(performWorkWrap,workWrapProgram) where++import Control.Monad.Writer.Strict hiding(Product(..))+import Data.Maybe++import DataConstructors+import E.CPR+import E.E+import E.Program+import E.Traverse+import E.TypeCheck+import E.Values+import GenUtil+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import Stats hiding(null)+import Support.CanType+import Util.SetLike+import qualified E.Demand as Demand+import qualified Info.Info as Info++data Arg =+    Absent+    | Cons Constructor [(Arg,TVr)]+    | Plain++isPlain Plain = True+isPlain _ = False++fsubs Demand.None = repeat Demand.lazy+fsubs (Demand.Product xs) = xs ++ repeat Demand.lazy++wrappable :: Monad m =>+    DataTable   -- ^ data table+    -> TVr      -- ^ function name we want to workwrap+    -> E        -- ^ function body+    -> m (Maybe Name,E,[(Arg,TVr)])  -- ^ (CPR Constructor,Body,Args)+wrappable dataTable mtvr e@ELam {} = ans where+    cpr = maybe Top id (Info.lookup (tvrInfo mtvr))+    Demand.DemandSignature _ (_ Demand.:=> sa) = maybe Demand.absSig id (Info.lookup (tvrInfo mtvr))+    ans = f e ( sa ++ repeat Demand.lazy) cpr []+    g t@TVr { tvrIdent = eid } _ | isEmptyId eid = (Absent,t)+    g t (Demand.S subs)+       | Just con <- getProduct dataTable tt = (Cons con (as con),t)+         where+            as con = [ g TVr { tvrIdent = n, tvrType = st, tvrInfo = mempty } demand  | st <- slotTypes dataTable (conName con) tt | n <- tmpNames Val (tvrIdent t) | demand <- fsubs subs]+            tt = getType t+    g t Demand.Absent | isLifted (EVar t) = (Absent,t)+    g t _ = (Plain,t)+    f (ELam t e) (demand:ss) (Fun x) ts = f e ss x (g t demand:ts)+    f e _ (Tup n _) ts | isCPR n = return (Just n,e,reverse ts)+    f e _ (Tag [n]) ts | isCPR n = return (Just n,e,reverse ts)+    f e _ _ ts | any (not . isPlain . fst) ts = return (Nothing ,e,reverse ts)+    f _ _ _ _ = fail "not workwrapable"+    isCPR n | isBoxed n, onlyChild dataTable n = True+            | otherwise = False+    isBoxed n = isJust $ do+        Constructor { conInhabits = c } <- getConstructor n dataTable+        if c == s_Star then return () else do+        Constructor { conInhabits = c } <- getConstructor c dataTable+        if c == s_Star then return () else Nothing+wrappable _ _ _ = fail "Only lambdas are wrappable"++workerName x = case fromId x of+    Just y -> toId (toName Val ("W@",'f':show y))+    Nothing -> toId (toName Val ("W@",'f':show x))++tmpNames ns x = case fromId x of+    Just y  -> [toId (toName ns ("X@",'f':show y ++ "@" ++ show i)) | i <- [(1::Int)..] ]+    Nothing -> [toId (toName ns ("X@",'f':show x ++ "@" ++ show i)) | i <- [(1::Int)..] ]++workWrap' :: MonadStats m => DataTable -> TVr -> E -> m ((TVr,E),(TVr,E))+workWrap' _dataTable tvr _e+    | badProps `intersects` getProperties tvr = fail "Don't workwrap this"+    where badProps = fromList [prop_WRAPPER,prop_INLINE,prop_SUPERINLINE,prop_PLACEHOLDER,prop_NOINLINE]+workWrap' dataTable tvr e | isJust res = ans where+    res@(~(Just (cname,body,sargs))) = wrappable dataTable tvr e+    args = snds sargs+    args' = concatMap f sargs where+        f (Absent,_) = []+        f (Plain,t) = [t]+        f (Cons c ts,_) = concatMap f ts+    lets = concatMap f (zip sargs (map show naturals)) where+        f ((Absent,t),n) = [(t,EError ("WorkWrap.Absent." ++ tvrShowName tvr ++ "." ++ n) (getType t))]+        f ((Plain,_),_) = []+        f ((Cons c ts,t),n) = [(t,ELit (updateLit dataTable litCons { litName = conName c, litArgs = map EVar (snds ts), litType = getType t }))] ++ concatMap f (zip ts [ n ++ "." ++ show i | i <- naturals])+    cases e = f sargs where+        f [] = e+        f ((Absent,_):rs) = f rs+        f ((Plain,_):rs) = f rs+        f ((Cons c ts,t):rs) = eCase (EVar t) [Alt (updateLit dataTable litCons { litName = conName c, litArgs = snds ts, litType = getType t }) (f (ts ++ rs))] Unknown+    nprops = insert prop_WORKER $ getProperties tvr `intersection` fromList [prop_JOINPOINT, prop_ONESHOT]+    ans = doTicks >> return ((setProperty prop_WRAPPER tvr,wrapper),(tvr',worker))+    tvr' = putProperties nprops $ TVr { tvrIdent = workerName (tvrIdent tvr), tvrInfo = mempty, tvrType = wt }+    worker = foldr ELam body' (args' ++ navar) where+        body' = eLetRec lets $ case cname of+            Just cname -> eCase body [cb] Unknown where+                cb = Alt (updateLit dataTable litCons { litName = cname, litArgs = vars, litType = bodyTyp }) (if isSingleton then EVar sv else (ELit $ unboxedTuple (map EVar vars)))+            Nothing -> body+    wrapper = foldr ELam ne args where+        workerCall = (foldl EAp (EVar tvr') (map EVar args' ++ navalue))+        ne | Just cname <- cname, isSingleton = cases $ eStrictLet sv workerCall  (ELit $ updateLit dataTable litCons { litName = cname, litArgs = [EVar sv], litType = bodyTyp })+           | Just cname <- cname = let ca = Alt (unboxedTuple vars) (ELit $ updateLit dataTable litCons { litName = cname, litArgs = (map EVar vars), litType = bodyTyp }) in  cases $ eCase workerCall [ca] Unknown+           | otherwise = cases $ workerCall+    getName (Just x) = x+    getName Nothing  = error ("workWrap': cname = Nothing: tvr = "++show tvr)+    vars@(~[sv]) = [  tVr i t | t <- slotTypes dataTable (getName cname) bodyTyp | i <- newIds dontUseThese ]+    dontUseThese = freeIds (getType tvr) `mappend` freeIds bodyTyp --`mappend` freeIds (EAp (getType tvr) $ EAp (EVar tvr) e)+    isSingleton = case vars of+        [v] -> getType (getType v) == eHash+        _ -> False+    Just wt = typecheck dataTable  worker+    Just bodyTyp = typecheck dataTable body+    -- This is to add a dummy arg so workers arn't turned into updatable CAFs+    --needsArg =  all (isJust . fst) sargs && null (concat [ xs | (Just (_,xs),_) <- sargs])+    needsArg = null args'+    (navar,navalue) = if needsArg then ([tvr { tvrType = ltTuple' []}],[eTuple' []]) else ([],[])+    doTicks = do+        case cname of+            --Just n -> mtick ("E.Workwrap.CPR.{" ++ tvrShowName tvr ++ "." ++ show n ++ "}")+            Just n -> mtick ("E.Workwrap.CPR.{"  ++ show n ++ "}")+            _ -> return ()+        let argw cn (Absent,_) = mtick $ cn ++ ".absent"+            argw cn (Cons n ts,_) = mtick  nname >> mapM_ (argw nname) ts where+                nname = cn ++ ".{"  ++ show (conName n) ++ "}"+            argw _ _ = return ()+        mapM_ (argw "E.Workwrap.arg") sargs+workWrap' _dataTable tvr e = fail "not workWrapable"++{-# NOINLINE workWrapProgram #-}+workWrapProgram :: Program -> Program+workWrapProgram prog = ans where+    (nds,stats) = performWorkWrap (progDataTable prog) (programDs prog)+    ans = programSetDs' nds prog { progStats = progStats prog `mappend` stats }++{-# NOINLINE performWorkWrap #-}+performWorkWrap :: DataTable -> [(TVr,E)] -> ([(TVr,E)],Stats.Stat)+performWorkWrap dataTable ds = runWriter (wwDs ds) where+    --wwDs :: [(TVr,E)] -> Stats.StatT Identity [(TVr,E)]+    wwDs ds = liftM concat $ mapM wwDef ds+    --wwDef :: (TVr,E) -> Stats.StatT Identity [(TVr,E)]+    wwDef (tvr,e) = case runStatT (workWrap' dataTable tvr e) of+        Just (((tx,x),(ty,y)),st) -> do+            --Stats.mtick a_workWrap+            tell st+            y' <- wwE y+            return ([ (tx,x), (ty,y') ] :: [(TVr,E)])+        Nothing -> do+            e' <- wwE e+            return ([(tvr,e')]:: [(TVr,E)])+    --wwE :: E -> Stats.StatT Identity E+    wwE ELetRec { eDefs = ds, eBody =  e } = do+        ds' <- wwDs ds+        e' <- wwE e+        return (ELetRec ds' e')+    wwE e = emapE' wwE e
+ src/FindFixpoint.hs view
@@ -0,0 +1,72 @@+module FindFixpoint(Ms, getVal, solve) where++import Data.Array+import Control.Monad.Writer+import Data.Array.IO+import Data.Graph+import Data.IntSet as IntSet+import Util.Gen++data Env b  = Env {-# UNPACK #-} !(IOArray Int b) {-# UNPACK #-} !(IOArray Int (IntSet)) {-# UNPACK #-} !Int+newtype Ms b c = Ms' (Env b -> IO c)++instance Monad (Ms b) where+    return a = Ms' (\_ -> return a)+    Ms' comp >>= fun+        = Ms' (\v  -> comp v >>= \r -> case fun r   of Ms' x -> x v)+    Ms' a >> Ms' b = Ms' $ \v -> a v >> b v+    fail x = Ms' (\_ -> (putErrDie x))+    {-# INLINE (>>) #-}+    {-# INLINE (>>=) #-}+    {-# INLINE return #-}++instance Functor (Ms b) where+    fmap = liftM++unMs' (Ms' x) = x++{-# INLINE getVal #-}+getVal ::  Int -> Ms b b+getVal n = Ms' $ \(Env arr ref self) ->  do+    s <- readArray ref n+    writeArray ref n $ (IntSet.insert self s)+    readArray arr n++solve :: (Eq b) => Maybe String -> b -> [Ms b b] -> IO [b]+solve str' empty vs = do+    let put = case str' of+            Just _ -> putErrLn+            Nothing -> const (return ())+        put' = case str' of+            Just _ -> putErr+            Nothing -> const (return ())+        Just str = str'+    let len = length vs+    put $ "Finding Fixpoint for " ++ show len ++ " variables: " ++  str+    arr <- newArray (0,len - 1) empty+    ref <- newArray (0,len - 1) IntSet.empty+    let as = [ (i,(unMs' f) (Env arr ref i))  |  f <- vs | i <- [0..]]+        fna = listArray (0,len - 1) (snds as)+    let li [] s | IntSet.null s  = return ()+        --li xs [] n = CharIO.putErr ("[" ++ show (I# n) ++ "]") >>   li xs xs 0#+        li [] s = do+            let g i = do+                    ds <- readArray ref i+                    return (i,i,IntSet.toList ds)+            ds <- mapM g (IntSet.toList s)+            let xs = flattenSCCs scc+                scc =  stronglyConnComp ds+            put' $ " " ++ show (IntSet.size s)+            li (reverse xs) IntSet.empty+        li (i:rs) s = do+            b <- readArray arr i+            b'<- fna Data.Array.! i+            case b == b' of+                True -> li rs (IntSet.delete i s)+                False -> do+                    writeArray arr i b'+                    ns <- readArray ref i+                    li rs (ns `IntSet.union` IntSet.delete i s)+    li [0 .. len - 1] IntSet.empty+    put $ " Done."+    mapM (readArray arr)  [0 .. len - 1]
+ src/Fixer/Fixer.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE BangPatterns #-}+-- find fixpoint of constraint problem++{- 2009.01.05: Lemmih++This may be obvious to a lot of people but it certainly wasn't obvious to me.++The following module help you solve problems that involve iterating over+a piece of data until some steady-state (aka. a fixpoint) is found.++One example problem would be dead-code elimination. To remove all dead+functions and function arguments, we have to mark everything that+could possibly be alive (we necessarily have to be conservative).+This is done in two steps:+1) Walk through the code and make a note of all the dependencies+   (eg. function 'x' uses function 'y' and function 'z'). The dependencies+   are then handed over to the fixpoint solver.+2) The fixpoint solver iterate over all the data and use the dependencies+   to propagate the usage information. That is, if 'x' is used then 'y' and 'z'+   are as well. The next iteration will deal with the dependencies of 'y' and 'z'.++Once there's no more usage information to propagate, we know we've found our fixpoint.+There are several other problems that require fixpoint iteration. Perhaps the most+distinguished is the heap points-to analysis we use to eliminate eval/apply calls.++-}++module Fixer.Fixer(+    Fixable(..),+    Value(),+    Rule(),+    Fixer(),+    addRule,+    ioToRule,+    conditionalRule,+    dynamicRule,+    findFixpoint,+    calcFixpoint,+    isSuperSetOf,+    modifiedSuperSetOf,+    newFixer,+    ioValue,+    newValue,+    readValue,+    readRawValue,+    value+    ) where++import Control.Monad.Trans+import Data.IORef+import Data.Monoid+import Data.Typeable+import Data.Unique+import System.IO(hFlush, stdout, Handle, hPutStr)+import Control.Monad+import qualified Data.Set as Set++-- | Fixable class, must satisfy the following rules+--+-- isBottom bottom == True+-- x `lub` x == x+-- x `lub` y == y `lub` x+-- x `lub` bottom == x+-- x `minus` bottom == x+-- bottom `minus` x == bottom+-- x `minus` y == z --> y `lub` z == x++class Fixable a where+    bottom :: a+    isBottom :: a -> Bool+    lub :: a -> a -> a+    minus :: a -> a -> a+    lte :: a -> a -> Bool+    lte x y = isBottom (x `minus` y)+    showFixable :: a -> String+    showFixable x | isBottom x = "."+                  | otherwise = "*"++data MkFixable = forall a . Fixable a => MkFixable (RvValue a)++data Fixer  = Fixer {+    vars :: {-# UNPACK #-} !(IORef [MkFixable]),+    todo :: {-# UNPACK #-} !(IORef (Set.Set MkFixable))+    }++newFixer :: MonadIO m => m Fixer+newFixer = liftIO $ do+    v <- newIORef []+    t <- newIORef Set.empty+    return Fixer { vars = v, todo = t }++newtype Rule = Rule { unRule :: IO () }+    deriving(Typeable)++instance Monoid Rule where+    mempty = Rule (return ())+    mappend (Rule a) (Rule b) = Rule (a >> b)+    mconcat rs = Rule $ sequence_ $ map unRule rs++instance Fixable a => Monoid (Value a) where+    mempty = value bottom+    mappend a b = UnionValue a b++data Value a = IOValue (IO (Value a)) | UnionValue (Value a) (Value a) | ConstValue a | IV (RvValue a)+    deriving(Typeable)++instance Fixable a => Show (Value a) where+    showsPrec _ (ConstValue a) = showString "<<" . showString (showFixable a) . showString ">>"+    showsPrec _ (UnionValue a b) = showString "<<" . shows a . shows b . showString ">>"+    showsPrec _ (IOValue _) = showString "<<IO>>"+    showsPrec _ (IV a) = showString "<<" . shows (hashUnique $ ident a) . showString ">>"++data RvValue a = RvValue {+    ident :: !Unique,+    action :: {-# UNPACK #-} !(IORef [a -> IO ()]),+    pending :: {-# UNPACK #-} !(IORef a),+    current :: {-# UNPACK #-} !(IORef a),+    fixer :: Fixer+    }++instance Eq MkFixable where+    MkFixable a == MkFixable b = ident a == ident b+    MkFixable a /= MkFixable b = ident a /= ident b+instance Ord MkFixable where+    MkFixable a `compare` MkFixable b = ident a `compare` ident b+    MkFixable a >= MkFixable b = ident a >= ident b+    MkFixable a <= MkFixable b = ident a <= ident b+    MkFixable a > MkFixable b = ident a > ident b+    MkFixable a < MkFixable b = ident a < ident b++value :: a -> Value a+value x = ConstValue x++-- | mainly for internal use+ioValue :: IO (Value a) -> Value a+ioValue iov = IOValue iov++newValue :: (MonadIO m,Fixable a) => Fixer -> a -> m (Value a)+newValue fixer@Fixer { vars = vars } v = liftIO $ do+    ident <- newUnique+    pending <- newIORef bottom+    current <- newIORef bottom+    action <- newIORef []+    let value =  IV rv+        rv =  RvValue { ident = ident, fixer = fixer, current = current, pending = pending, action = action }+    modifyIORef vars (MkFixable rv:)+    propagateValue v rv+    return value++addAction :: Fixable a => Value a -> (a -> IO ())  -> IO ()+addAction (ConstValue n) act = act n+addAction (UnionValue a b) act = addAction a act >> addAction b act+addAction (IOValue v) act = v >>= (`addAction` act)+addAction (IV v) act = do+    modifyIORef (action v) (act:)+    c <- readIORef (current v)+    unless (isBottom c) (act c)++-- | add a rule to the current set+addRule :: MonadIO m => Rule -> m ()+addRule (Rule act) = liftIO act++-- | turn an IO action into a Rule+ioToRule :: IO () -> Rule+ioToRule act = Rule act++-- | the function must satisfy the rule that if a >= b then f(a) >= f(b)++modifiedSuperSetOf :: (Fixable a, Fixable b) =>  Value b -> Value a -> (a -> b) -> Rule+modifiedSuperSetOf (IV rv) (ConstValue cv) r = Rule $ propagateValue (r cv) rv+modifiedSuperSetOf (IV rv) v2 r = Rule $ addAction v2 (\x -> propagateValue (r x) rv)+modifiedSuperSetOf (IOValue iov) v2 r = Rule $ iov >>= \v1 -> unRule $ modifiedSuperSetOf v1 v2 r+modifiedSuperSetOf (ConstValue vb) (ConstValue va)  f | f va `lte` vb =  Rule $ return ()+modifiedSuperSetOf ca@ConstValue {}  cb _ =  Rule $ fail ("Fixer.modifedSuperSetOf: You cannot modify a constant value:" ++ show(ca,cb))+modifiedSuperSetOf UnionValue {} _ _ =  Rule $ fail "Fixer: You cannot modify a union value"++isSuperSetOf :: Fixable a => Value a -> Value a -> Rule+(IV rv) `isSuperSetOf` (ConstValue v2) = Rule $ propagateValue v2 rv+(IV rv) `isSuperSetOf` v2 = Rule $ addAction v2 (\x -> propagateValue x rv)+(IOValue iov) `isSuperSetOf` v2 = Rule $ iov >>= unRule . (`isSuperSetOf` v2)+ConstValue v1 `isSuperSetOf` ConstValue v2 | v2 `lte` v1 =  Rule $ return ()+ConstValue {} `isSuperSetOf` _ = Rule $  fail "Fixer.isSuperSetOf: You cannot modify a constant value"+UnionValue {} `isSuperSetOf` _ = Rule $  fail "Fixer: You cannot modify a union value"++-- | the function must satisfy the rule that if a >= b then f(a) implies f(b)+conditionalRule :: Fixable a => (a -> Bool) -> Value a -> Rule -> Rule+conditionalRule cond v (Rule act) = Rule $ addAction v (\x -> if cond x then act else return ())++dynamicRule  :: Fixable a =>  Value a -> (a -> Rule) -> Rule+dynamicRule v dr = Rule $ addAction v (unRule . dr)++propagateValue :: Fixable a => a -> RvValue a -> IO ()+propagateValue p v = do+    if isBottom p then return () else do+    (modifyIORef (todo $ fixer v) (Set.insert $ MkFixable v))+    modifyIORef (pending v) (lub p)++-- | read result, calculating fixpoint if needed+readValue :: (Fixable a,MonadIO m) => Value a -> m a+readValue (IV v) = liftIO $ do+    findFixpoint Nothing (fixer v)+    readIORef (current v)+readValue (IOValue iov) = liftIO iov >>= readValue+readValue (ConstValue v) = return v+readValue (UnionValue a b) = liftIO $ do+    a' <- readValue a+    b' <- readValue b+    return (lub a' b')++readRawValue :: (Fixable a,MonadIO m) => Value a -> m a+readRawValue (IV v) = liftIO $ do+    readIORef (current v)+readRawValue (IOValue iov) = liftIO iov >>= readRawValue+readRawValue (ConstValue v) = return v+readRawValue (UnionValue a b) = liftIO $ do+    a' <- readRawValue a+    b' <- readRawValue b+    return (lub a' b')++calcFixpoint :: MonadIO m => String -> Fixer -> m ()+calcFixpoint s fixer = findFixpoint (Just (s,stdout)) fixer++-- | find fixpoint, perhaps printing debugging information to specified handle. will not print anything if no calculation needed.+findFixpoint :: MonadIO m => Maybe (String,Handle) ->  Fixer -> m ()+findFixpoint msh@(~(Just (mstring,_))) Fixer { vars = vars, todo = todo } = liftIO $ do+    to <- readIORef todo+    if Set.null to then return () else do+    vars <- readIORef vars+    let f [] !tl !n | n > 0, tl /= 0 = do+            vs <- readIORef todo+            writeIORef todo Set.empty+            mputStr "(" >> mputStr (show n) >> mputStr ")" >> mFlush+            f (Set.toList vs) (tl - 1) 0+        f [] _ n | n > 0 = mputStr "[Aborting]\n" >> mFlush >> return ()+        f [] _ _ = mputStr "\n" >> mFlush >> return ()+        f (MkFixable v:vs) tl n = do+            p <- readIORef (pending v)+            c <- readIORef (current v)+            let diff = p `minus` c+            --if isBottom diff then f vs n else do+            if p `lte` c then f vs tl n else do+            as <- readIORef (action v)+            writeIORef (current v) (p `lub` c)+            writeIORef (pending v) bottom+            --putStr "["+            --putStr (showFixable diff)+            --putStr "]"+            mapM_ ($ diff) as+            f vs tl (n + 1)+        mputStr s = case msh of+            Nothing -> return ()+            Just (_,h) -> hPutStr h s+        mFlush = case msh of+            Nothing -> return ()+            Just (_,h) -> hFlush h+    mputStr $ "Finding fixpoint for " ++ mstring ++ ": " ++ "[" ++ show (Set.size to) ++ "]"+    mFlush+    f (Set.toList to) (-1::Int) (0::Int)++-- some useful instances++instance Ord n => Fixable (Set.Set n)  where+    bottom = Set.empty+    isBottom = Set.null+    lub a b = Set.union a b+    minus a b = a Set.\\ b++instance Fixable Bool where+    bottom = False+    isBottom x = x == False+    lub a b = a || b+    minus True False = True+    minus False True = False+    minus True True = False+    minus False False = False++-- bottom is zero and the lub is the maximum of integer values, as in this is the lattice of maximum, not the additive one.+instance Fixable Int where+    bottom = 0+    isBottom = (0 ==)+    lub a b = max a b+    minus a b | a > b = a+    minus _ _ = 0++instance (Fixable a,Fixable b) => Fixable (a,b) where+    bottom = (bottom,bottom)+    isBottom (a,b) = isBottom a && isBottom b+    lub (x,y) (x',y') = (lub x x', lub y y')+    minus (x,y) (x',y') = (minus x x', minus y y')++-- the maybe instance creates a new bottom of nothing. note that (Just bottom) is a distinct point.+instance Fixable a => Fixable (Maybe a) where+    bottom = Nothing+    isBottom Nothing = True+    isBottom _ = False+    lub Nothing b = b+    lub a Nothing = a+    lub (Just a) (Just b) = Just (lub a b)+    minus (Just a) (Just b) = Just (minus a b)+    minus (Just a) Nothing = Just a+    minus Nothing _ = Nothing
+ src/Fixer/Supply.hs view
@@ -0,0 +1,49 @@+module Fixer.Supply(+    Supply(),+    newSupply,+    supplyReadValues,+    sValue,+    readSValue,+    supplyValue+    ) where++import Control.Monad.Trans+import Data.IORef+import Data.Typeable+import Fixer.Fixer+import qualified Data.Map as Map++-- maps b's to values of a's, creating them as needed.++data Supply b a = Supply Fixer {-# UNPACK #-} !(IORef (Map.Map b (Value a)))+    deriving(Typeable)++newSupply :: MonadIO m => Fixer -> m (Supply b a)+newSupply fixer = liftIO $ do+    ref <- newIORef Map.empty+    return $ Supply fixer ref++supplyValue :: (MonadIO m, Ord b, Fixable a) => Supply b a -> b -> m (Value a)+supplyValue (Supply fixer ref) b = liftIO $ do+    mp <- readIORef ref+    case Map.lookup b mp of+        Just v -> return v+        Nothing -> do+            v <- newValue fixer bottom+            modifyIORef ref (Map.insert b v)+            return v++sValue :: (Ord b, Fixable a) => Supply b a -> b -> (Value a)+sValue s b = ioValue (supplyValue s b)++supplyReadValues :: (Fixable a,MonadIO m) => Supply b a -> m [(b,a)]+supplyReadValues (Supply _fixer ref) = liftIO $ do+    mp <- readIORef ref+    flip mapM (Map.toList mp) $ \ (b,va) -> do+        a <- readValue va+        return (b,a)++readSValue :: (MonadIO m, Ord b, Fixable a) => Supply b a -> b -> m a+readSValue s b = do+    v <- supplyValue s b+    readValue v
+ src/Fixer/VMap.hs view
@@ -0,0 +1,114 @@+module Fixer.VMap(+    VMap(),+    Proxy(..),+    vmapSingleton,+    vmapArgSingleton,+    vmapArg,+    vmapValue,+    vmapMember,+    vmapProxyIndirect,+    vmapPlaceholder,+    vmapDropArgs,+    vmapHeads+    )where++import Data.Monoid(Monoid(..))+import Data.Typeable+import Data.List(intersperse)+import qualified Data.Map as Map+import qualified Data.Set as Set++import Doc.DocLike+import Fixer.Fixer+import GenUtil++-- | General data type for finding the fixpoint of a general tree-like structure.++data VMap p n = VMap {+    vmapArgs    :: Map.Map (n,Int) (VMap p n),+    vmapNodes   :: Either (Proxy p) (Set.Set n)+    }+    deriving(Typeable)++data Proxy p = Proxy p | DepthExceeded+    deriving(Eq,Ord,Typeable)++instance Show p => Show (Proxy p) where+    showsPrec n (Proxy p) = showsPrec n p+    showsPrec n DepthExceeded = ('*':)++emptyVMap :: (Ord p, Ord n) => VMap p n+emptyVMap = VMap { vmapArgs = mempty, vmapNodes = Right mempty }++vmapSingleton :: (Ord p, Ord n) => n -> VMap p n+vmapSingleton n = emptyVMap { vmapNodes = Right $ Set.singleton n }++vmapArgSingleton :: (Ord p,Ord n,Show p,Show n) => n -> Int -> VMap p n -> VMap p n+vmapArgSingleton n i v+    | isBottom v = emptyVMap+    | otherwise = pruneVMap $ emptyVMap { vmapArgs = Map.singleton (n,i) v }++vmapArg :: (Ord p,Ord n,Show p,Show n) => n -> Int -> VMap p n -> VMap p n+vmapArg n i vm@VMap { vmapArgs =  map } = case Map.lookup (n,i) map of+    Just x -> x `lub` vmapProxyIndirect i vm+    Nothing -> vmapProxyIndirect i vm++vmapProxyIndirect :: (Show p,Show n,Ord p,Ord n,Fixable (VMap p n)) => Int -> VMap p n -> VMap p n+vmapProxyIndirect _ VMap { vmapNodes = Left l } = emptyVMap { vmapNodes = Left l }+vmapProxyIndirect _ _ = emptyVMap++vmapValue :: (Show p,Show n,Ord p,Ord n) => n -> [VMap p n] -> VMap p n+vmapValue n xs = pruneVMap VMap { vmapArgs = Map.fromAscList (zip (zip (repeat n) [0..]) xs), vmapNodes = Right $ Set.singleton n }++vmapPlaceholder :: (Show p,Show n,Ord p,Ord n) => p  -> VMap p n+vmapPlaceholder p = emptyVMap { vmapNodes = Left (Proxy p) }++vmapDropArgs :: Ord n => VMap p n -> VMap p n+vmapDropArgs vm = vm { vmapArgs = mempty }++vmapHeads :: Monad m => VMap p n -> m [n]+vmapHeads VMap { vmapNodes = Left _ } = fail "vmapHeads: VMap is unknown"+vmapHeads VMap { vmapNodes = Right set } = return $ Set.toList set++vmapMember :: Ord n => n -> VMap p n -> Bool+vmapMember n VMap { vmapNodes = Left _ } = True+vmapMember n VMap { vmapNodes = Right set } = n `Set.member` set++pruneVMap :: (Ord n,Ord p,Show n,Show p) => VMap p n -> VMap p n+pruneVMap vmap = f (7::Int) vmap where+    f 0 _ = emptyVMap { vmapNodes = Left DepthExceeded }+    f _ VMap { vmapNodes = Left p} = emptyVMap {vmapNodes = Left p}+    f n VMap { vmapArgs = map, vmapNodes =  set} = VMap {vmapArgs = map', vmapNodes = set} where+        map' = Map.filter g (Map.map (f (n - 1)) map)+        g vs = not $ isBottom vs++instance (Ord p,Ord n,Show p,Show n) => Show (VMap p n) where+    showsPrec n VMap { vmapNodes = Left p } = showsPrec n p+    showsPrec _ VMap { vmapArgs = n, vmapNodes = Right s } = braces (hcat (intersperse (char ',') $ (map f $ snub $ (fsts $ Map.keys n) ++ Set.toList s) )) where+        f a = (if a `Set.member` s then tshow a else char '#' <> tshow a) <> (if null (g a) then empty else tshow (g a))+        g a = sortUnder fst [ (i,v) | ((a',i),v) <- Map.toList n, a' == a ]++instance (Show p,Show n,Ord p,Ord n) => Fixable (VMap p n) where+    bottom = emptyVMap+    isBottom VMap { vmapArgs = m, vmapNodes = Right s } = Map.null m && Set.null s+    isBottom _ = False+    lub x y | x `lte` y = y+    lub x y | y `lte` x = x+    lub VMap { vmapNodes = Left p } _ = emptyVMap { vmapNodes = Left p }+    lub _ VMap { vmapNodes = Left p } = emptyVMap { vmapNodes = Left p }+    lub VMap { vmapArgs = as, vmapNodes = Right ns } VMap { vmapArgs = as', vmapNodes = Right ns'} = pruneVMap $ VMap {vmapArgs = Map.unionWith lub as as', vmapNodes = Right $ Set.union ns ns' }+    minus _ VMap { vmapNodes = Left _ } = bottom+    minus x@VMap { vmapNodes = Left _ } _ = x+    minus VMap { vmapArgs = n1, vmapNodes = Right w1} VMap { vmapArgs = n2, vmapNodes = Right w2 } = pruneVMap $ VMap { vmapArgs = Map.fromAscList $ [+            case Map.lookup (a,i) n2 of+                Just v' ->  ((a,i),v `minus` v')+                Nothing ->  ((a,i),v)+        | ((a,i),v) <- Map.toAscList n1 ], vmapNodes = Right (w1 Set.\\ w2) }+    lte _ VMap { vmapNodes = Left _ } = True+    lte VMap { vmapNodes = Left _ } _ = False+    lte x@VMap { vmapArgs = as, vmapNodes = Right ns } y@VMap { vmapArgs = as', vmapNodes = Right ns'} =  (Set.null (ns Set.\\ ns') && (Map.null $ Map.differenceWith (\a b -> if a `lte` b then Nothing else Just undefined) as as'))+    showFixable x = show x++instance (Show p,Show n,Ord p,Ord n) => Monoid (VMap p n) where+    mempty = bottom+    mappend = lub
+ src/FlagDump.hs view
@@ -0,0 +1,247 @@+module FlagDump(Flag(..),process,helpMsg,helpFlags) where++import qualified Data.Set as Set++-- | Flags+data Flag =+      AllTypes          -- ^ show unified type table, after everything has been typechecked+    | Aspats            -- ^ show as patterns+    | Atom              -- ^ dump atom table on exit+    | Bindgroups        -- ^ show bindgroups+    | BoxySteps         -- ^ show step by step what the type inferencer is doing+    | C                 -- ^ don't delete C source file after compilation+    | Class             -- ^ detailed information on each class+    | ClassSummary      -- ^ summary of all classes+    | Core              -- ^ show intermediate core code+    | CoreAfterlift     -- ^ show final core before writing ho file+    | CoreBeforelift    -- ^ show core before lambda lifting+    | CoreInitial       -- ^ show core right after E.FromHs conversion+    | CoreMangled       -- ^ de-typed core right before it is converted to grin+    | CoreMini          -- ^ show details even when optimizing individual functions+    | CorePass          -- ^ show each iteration of code while transforming+    | CoreSteps         -- ^ show what happens in each pass+    | Datatable         -- ^ show data table of constructors+    | DatatableBuiltin  -- ^ show data table entries for some built in types+    | Dcons             -- ^ data constructors+    | Decls             -- ^ processed declarations+    | Defs              -- ^ Show all defined names in a module+    | Derived           -- ^ show generated derived instances+    | EAlias            -- ^ show expanded aliases+    | EInfo             -- ^ show info tags on all bound variables+    | ESize             -- ^ print the size of E after each pass+    | EVerbose          -- ^ print very verbose version of E code always+    | Exports           -- ^ show which names are exported from each module+    | Grin              -- ^ dump all grin to the screen+    | GrinDatalog       -- ^ print out grin information in a format suitable for loading into a database+    | GrinFinal         -- ^ final grin before conversion to C+    | GrinGraph         -- ^ print dot file of final grin code to outputname_grin.dot+    | GrinInitial       -- ^ grin right after conversion from core+    | GrinNormalized    -- ^ grin right after first normalization+    | GrinPosteval      -- ^ show grin code just before eval\/apply inlining+    | GrinPreeval       -- ^ show grin code just before eval\/apply inlining+    | Imports           -- ^ show in scope names for each module+    | Ini               -- ^ all ini configuration options+    | Instance          -- ^ show instances+    | Kind              -- ^ show results of kind inference for each module+    | KindSteps         -- ^ show steps of kind inference+    | OptimizationStats -- ^ show combined stats of optimization passes+    | Parsed            -- ^ parsed code+    | Preprocessed      -- ^ code after preprocessing\/deliting+    | Program           -- ^ impl expls, the whole shebang.+    | Progress          -- ^ show basic progress indicators+    | Renamed           -- ^ code after uniqueness renaming+    | Rules             -- ^ show all user rules and catalysts+    | RulesSpec         -- ^ show specialization rules+    | SccModules        -- ^ show strongly connected modules in dependency order+    | Sigenv            -- ^ initial signature environment+    | Srcsigs           -- ^ processed signatures from source code+    | Stats             -- ^ show extra information about stuff+    | Steps             -- ^ show interpreter go+    | Tags              -- ^ list of all tags and their types+    | The               -- ^ '-d' flag. The following is a list of possible parameters you can pass to+    | Types             -- ^ display unified type table containing all defined names+    deriving(Eq,Ord,Bounded)++instance Show Flag where+    show The = "the"+    show Ini = "ini"+    show Preprocessed = "preprocessed"+    show Renamed = "renamed"+    show Parsed = "parsed"+    show Derived = "derived"+    show Imports = "imports"+    show Exports = "exports"+    show SccModules = "scc-modules"+    show Defs = "defs"+    show Kind = "kind"+    show KindSteps = "kind-steps"+    show Dcons = "dcons"+    show ClassSummary = "class-summary"+    show Class = "class"+    show Instance = "instance"+    show Bindgroups = "bindgroups"+    show Types = "types"+    show AllTypes = "all-types"+    show Sigenv = "sigenv"+    show Srcsigs = "srcsigs"+    show Program = "program"+    show Decls = "decls"+    show BoxySteps = "boxy-steps"+    show Aspats = "aspats"+    show CorePass = "core-pass"+    show CoreSteps = "core-steps"+    show CoreMini = "core-mini"+    show CoreInitial = "core-initial"+    show CoreBeforelift = "core-beforelift"+    show CoreAfterlift = "core-afterlift"+    show Core = "core"+    show CoreMangled = "core-mangled"+    show DatatableBuiltin = "datatable-builtin"+    show Datatable = "datatable"+    show OptimizationStats = "optimization-stats"+    show Rules = "rules"+    show RulesSpec = "rules-spec"+    show EInfo = "e-info"+    show EVerbose = "e-verbose"+    show EAlias = "e-alias"+    show ESize = "e-size"+    show Tags = "tags"+    show Steps = "steps"+    show Grin = "grin"+    show GrinDatalog = "grin-datalog"+    show GrinPreeval = "grin-preeval"+    show GrinPosteval = "grin-posteval"+    show GrinInitial = "grin-initial"+    show GrinNormalized = "grin-normalized"+    show GrinGraph = "grin-graph"+    show GrinFinal = "grin-final"+    show C = "c"+    show Atom = "atom"+    show Progress = "progress"+    show Stats = "stats"++one "verbose" = Right $ foldr (.) id [ f | Right f <- [ one "progress"]]+one "the" = Right $ Set.insert The+one "no-the" = Right $ Set.delete The+one "core-mini" = Right $ Set.insert CoreMini+one "no-core-mini" = Right $ Set.delete CoreMini+one "kind-steps" = Right $ Set.insert KindSteps+one "no-kind-steps" = Right $ Set.delete KindSteps+one "veryverbose" = Right $ foldr (.) id [ f | Right f <- [ one "progress",one "stats"]]+one "ini" = Right $ Set.insert Ini+one "no-ini" = Right $ Set.delete Ini+one "program" = Right $ Set.insert Program+one "no-program" = Right $ Set.delete Program+one "atom" = Right $ Set.insert Atom+one "no-atom" = Right $ Set.delete Atom+one "grin-preeval" = Right $ Set.insert GrinPreeval+one "no-grin-preeval" = Right $ Set.delete GrinPreeval+one "grin-graph" = Right $ Set.insert GrinGraph+one "no-grin-graph" = Right $ Set.delete GrinGraph+one "e-alias" = Right $ Set.insert EAlias+one "no-e-alias" = Right $ Set.delete EAlias+one "renamed" = Right $ Set.insert Renamed+one "no-renamed" = Right $ Set.delete Renamed+one "datatable-builtin" = Right $ Set.insert DatatableBuiltin+one "no-datatable-builtin" = Right $ Set.delete DatatableBuiltin+one "aspats" = Right $ Set.insert Aspats+one "no-aspats" = Right $ Set.delete Aspats+one "grin-final" = Right $ Set.insert GrinFinal+one "no-grin-final" = Right $ Set.delete GrinFinal+one "instance" = Right $ Set.insert Instance+one "no-instance" = Right $ Set.delete Instance+one "defs" = Right $ Set.insert Defs+one "no-defs" = Right $ Set.delete Defs+one "c" = Right $ Set.insert C+one "no-c" = Right $ Set.delete C+one "e-size" = Right $ Set.insert ESize+one "no-e-size" = Right $ Set.delete ESize+one "core-initial" = Right $ Set.insert CoreInitial+one "no-core-initial" = Right $ Set.delete CoreInitial+one "class" = Right $ Set.insert Class+one "no-class" = Right $ Set.delete Class+one "datatable" = Right $ Set.insert Datatable+one "no-datatable" = Right $ Set.delete Datatable+one "core-afterlift" = Right $ Set.insert CoreAfterlift+one "no-core-afterlift" = Right $ Set.delete CoreAfterlift+one "steps" = Right $ Set.insert Steps+one "no-steps" = Right $ Set.delete Steps+one "all-types" = Right $ Set.insert AllTypes+one "no-all-types" = Right $ Set.delete AllTypes+one "types" = Right $ Set.insert Types+one "no-types" = Right $ Set.delete Types+one "core" = Right $ Set.insert Core+one "no-core" = Right $ Set.delete Core+one "preprocessed" = Right $ Set.insert Preprocessed+one "no-preprocessed" = Right $ Set.delete Preprocessed+one "rules" = Right $ Set.insert Rules+one "no-rules" = Right $ Set.delete Rules+one "exports" = Right $ Set.insert Exports+one "no-exports" = Right $ Set.delete Exports+one "core-steps" = Right $ Set.insert CoreSteps+one "no-core-steps" = Right $ Set.delete CoreSteps+one "sigenv" = Right $ Set.insert Sigenv+one "no-sigenv" = Right $ Set.delete Sigenv+one "kind" = Right $ Set.insert Kind+one "no-kind" = Right $ Set.delete Kind+one "rules-spec" = Right $ Set.insert RulesSpec+one "no-rules-spec" = Right $ Set.delete RulesSpec+one "optimization-stats" = Right $ Set.insert OptimizationStats+one "no-optimization-stats" = Right $ Set.delete OptimizationStats+one "srcsigs" = Right $ Set.insert Srcsigs+one "no-srcsigs" = Right $ Set.delete Srcsigs+one "class-summary" = Right $ Set.insert ClassSummary+one "no-class-summary" = Right $ Set.delete ClassSummary+one "dcons" = Right $ Set.insert Dcons+one "no-dcons" = Right $ Set.delete Dcons+one "grin-posteval" = Right $ Set.insert GrinPosteval+one "no-grin-posteval" = Right $ Set.delete GrinPosteval+one "grin-initial" = Right $ Set.insert GrinInitial+one "no-grin-initial" = Right $ Set.delete GrinInitial+one "parsed" = Right $ Set.insert Parsed+one "no-parsed" = Right $ Set.delete Parsed+one "core-pass" = Right $ Set.insert CorePass+one "no-core-pass" = Right $ Set.delete CorePass+one "e-verbose" = Right $ Set.insert EVerbose+one "no-e-verbose" = Right $ Set.delete EVerbose+one "core-mangled" = Right $ Set.insert CoreMangled+one "no-core-mangled" = Right $ Set.delete CoreMangled+one "progress" = Right $ Set.insert Progress+one "no-progress" = Right $ Set.delete Progress+one "imports" = Right $ Set.insert Imports+one "no-imports" = Right $ Set.delete Imports+one "stats" = Right $ Set.insert Stats+one "no-stats" = Right $ Set.delete Stats+one "core-beforelift" = Right $ Set.insert CoreBeforelift+one "no-core-beforelift" = Right $ Set.delete CoreBeforelift+one "e-info" = Right $ Set.insert EInfo+one "no-e-info" = Right $ Set.delete EInfo+one "decls" = Right $ Set.insert Decls+one "no-decls" = Right $ Set.delete Decls+one "tags" = Right $ Set.insert Tags+one "no-tags" = Right $ Set.delete Tags+one "derived" = Right $ Set.insert Derived+one "no-derived" = Right $ Set.delete Derived+one "bindgroups" = Right $ Set.insert Bindgroups+one "no-bindgroups" = Right $ Set.delete Bindgroups+one "grin-datalog" = Right $ Set.insert GrinDatalog+one "no-grin-datalog" = Right $ Set.delete GrinDatalog+one "boxy-steps" = Right $ Set.insert BoxySteps+one "no-boxy-steps" = Right $ Set.delete BoxySteps+one "scc-modules" = Right $ Set.insert SccModules+one "no-scc-modules" = Right $ Set.delete SccModules+one "grin-normalized" = Right $ Set.insert GrinNormalized+one "no-grin-normalized" = Right $ Set.delete GrinNormalized+one "grin" = Right $ Set.insert Grin+one "no-grin" = Right $ Set.delete Grin+one x = Left x++{-# NOINLINE process #-}+process s xs = foldr f (s,[]) (map one xs) where+   f (Right g) (s,xs) = (g s,xs)+   f (Left x) (s,xs) = (s,x:xs)++{-# NOINLINE helpMsg #-}+helpMsg = "\n-- Front End --\ndefs            Show all defined names in a module\nderived         show generated derived instances\nexports         show which names are exported from each module\nimports         show in scope names for each module\nini             all ini configuration options\nparsed          parsed code\npreprocessed    code after preprocessing/deliting\nrenamed         code after uniqueness renaming\nscc-modules     show strongly connected modules in dependency order\n\n-- Type Checker --\nall-types       show unified type table, after everything has been\n                typechecked\naspats          show as patterns\nbindgroups      show bindgroups\nboxy-steps      show step by step what the type inferencer is doing\nclass           detailed information on each class\nclass-summary   summary of all classes\ndcons           data constructors\ndecls           processed declarations\ninstance        show instances\nkind            show results of kind inference for each module\nkind-steps      show steps of kind inference\nprogram         impl expls, the whole shebang.\nsigenv          initial signature environment\nsrcsigs         processed signatures from source code\ntypes           display unified type table containing all defined names\n\n-- Intermediate code --\ncore            show intermediate core code\ncore-afterlift  show final core before writing ho file\ncore-beforelift show core before lambda lifting\ncore-initial    show core right after E.FromHs conversion\ncore-mangled    de-typed core right before it is converted to grin\ncore-mini       show details even when optimizing individual functions\ncore-pass       show each iteration of code while transforming\ncore-steps      show what happens in each pass\ndatatable       show data table of constructors\ndatatable-builtin show data table entries for some built in types\ne-alias         show expanded aliases\ne-info          show info tags on all bound variables\ne-size          print the size of E after each pass\ne-verbose       print very verbose version of E code always\noptimization-stats show combined stats of optimization passes\nrules           show all user rules and catalysts\nrules-spec      show specialization rules\n\n-- Grin code --\ngrin            dump all grin to the screen\ngrin-datalog    print out grin information in a format suitable for\n                loading into a database\ngrin-final      final grin before conversion to C\ngrin-graph      print dot file of final grin code to\n                outputname_grin.dot\ngrin-initial    grin right after conversion from core\ngrin-normalized grin right after first normalization\ngrin-posteval   show grin code just before eval/apply inlining\ngrin-preeval    show grin code just before eval/apply inlining\nsteps           show interpreter go\ntags            list of all tags and their types\n\n-- Backend code --\nc               don't delete C source file after compilation\n\n-- Internal --\natom            dump atom table on exit\n\n-- General --\nprogress        show basic progress indicators\nstats           show extra information about stuff\nverbose         progress\nveryverbose     progress stats\n"+helpFlags = ["all-types", "aspats", "atom", "bindgroups", "boxy-steps", "c", "class", "class-summary", "core", "core-afterlift", "core-beforelift", "core-initial", "core-mangled", "core-mini", "core-pass", "core-steps", "datatable", "datatable-builtin", "dcons", "decls", "defs", "derived", "e-alias", "e-info", "e-size", "e-verbose", "exports", "grin", "grin-datalog", "grin-final", "grin-graph", "grin-initial", "grin-normalized", "grin-posteval", "grin-preeval", "imports", "ini", "instance", "kind", "kind-steps", "optimization-stats", "parsed", "preprocessed", "program", "progress", "renamed", "rules", "rules-spec", "scc-modules", "sigenv", "srcsigs", "stats", "steps", "tags", "the", "types", "verbose", "veryverbose"]+
+ src/FlagOpts.hs view
@@ -0,0 +1,135 @@+module FlagOpts(Flag(..),process,helpMsg,helpFlags) where++import qualified Data.Set as Set++-- | Flags+data Flag =+      BangPatterns      -- ^ - bang patterns+    | Boehm             -- ^ use Boehm garbage collector+    | Controlled        -- ^ with the '-f' flag, the following options are availible, you can+    | Cpp               -- ^ pass haskell source through c preprocessor+    | Debug             -- ^ enable debugging code in generated executable+    | Defaulting        -- ^ perform defaulting of ambiguous types+    | Exists            -- ^ - exists keyword for existential types recognized+    | Ffi               -- ^ support foreign function declarations+    | Forall            -- ^ - forall keyword for rank-n types and explicit quantification+    | FullInt           -- ^ extend Int and Word to 32 bits on a 32 bit machine (rather than 30)+    | GlobalOptimize    -- ^ perform whole program E optimization+    | InlinePragmas     -- ^ use inline pragmas+    | Jgc               -- ^ use the jgc garbage collector+    | Lint              -- ^ perform lots of extra type checks+    | M4                -- ^ pass haskell source through m4 preprocessor+    | MonomorphismRestriction -- ^ enforce monomorphism restriction+    | Negate            -- ^ any particular one by prepending 'no-' to it.+    | Prelude           -- ^ implicitly import Prelude+    | Profile           -- ^ enable profiling code in generated executable+    | Raw               -- ^ just evaluate main to WHNF and nothing else.+    | Rules             -- ^ use rules+    | Standalone        -- ^ compile to a standalone executable+    | TypeAnalysis      -- ^ perform a basic points-to analysis on types right after method generation+    | TypeFamilies      -- ^ type\/data family support+    | UnboxedTuples     -- ^ allow unboxed tuple syntax to be recognized+    | UnboxedValues     -- ^ allow unboxed value syntax+    | UserKinds         -- ^ user defined kinds+    | Wrapper           -- ^ wrap main in exception handler+    deriving(Eq,Ord,Bounded)++instance Show Flag where+    show Controlled = "controlled"+    show Negate = "negate"+    show UnboxedTuples = "unboxed-tuples"+    show UnboxedValues = "unboxed-values"+    show Ffi = "ffi"+    show Cpp = "cpp"+    show M4 = "m4"+    show Prelude = "prelude"+    show TypeFamilies = "type-families"+    show UserKinds = "user-kinds"+    show Forall = "forall"+    show Exists = "exists"+    show BangPatterns = "bang-patterns"+    show MonomorphismRestriction = "monomorphism-restriction"+    show Defaulting = "defaulting"+    show Lint = "lint"+    show InlinePragmas = "inline-pragmas"+    show Rules = "rules"+    show TypeAnalysis = "type-analysis"+    show GlobalOptimize = "global-optimize"+    show Standalone = "standalone"+    show FullInt = "full-int"+    show Wrapper = "wrapper"+    show Boehm = "boehm"+    show Jgc = "jgc"+    show Profile = "profile"+    show Debug = "debug"+    show Raw = "raw"++one "profile" = Right $ Set.insert Profile+one "no-profile" = Right $ Set.delete Profile+one "boehm" = Right $ Set.insert Boehm+one "no-boehm" = Right $ Set.delete Boehm+one "jgc" = Right $ Set.insert Jgc+one "no-jgc" = Right $ Set.delete Jgc+one "m4" = Right $ Set.insert M4+one "no-m4" = Right $ Set.delete M4+one "defaulting" = Right $ Set.insert Defaulting+one "no-defaulting" = Right $ Set.delete Defaulting+one "lint" = Right $ Set.insert Lint+one "no-lint" = Right $ Set.delete Lint+one "ffi" = Right $ Set.insert Ffi+one "no-ffi" = Right $ Set.delete Ffi+one "rules" = Right $ Set.insert Rules+one "no-rules" = Right $ Set.delete Rules+one "monomorphism-restriction" = Right $ Set.insert MonomorphismRestriction+one "no-monomorphism-restriction" = Right $ Set.delete MonomorphismRestriction+one "prelude" = Right $ Set.insert Prelude+one "no-prelude" = Right $ Set.delete Prelude+one "controlled" = Right $ Set.insert Controlled+one "no-controlled" = Right $ Set.delete Controlled+one "debug" = Right $ Set.insert Debug+one "no-debug" = Right $ Set.delete Debug+one "wrapper" = Right $ Set.insert Wrapper+one "no-wrapper" = Right $ Set.delete Wrapper+one "bang-patterns" = Right $ Set.insert BangPatterns+one "no-bang-patterns" = Right $ Set.delete BangPatterns+one "unboxed-values" = Right $ Set.insert UnboxedValues+one "no-unboxed-values" = Right $ Set.delete UnboxedValues+one "type-families" = Right $ Set.insert TypeFamilies+one "no-type-families" = Right $ Set.delete TypeFamilies+one "inline-pragmas" = Right $ Set.insert InlinePragmas+one "no-inline-pragmas" = Right $ Set.delete InlinePragmas+one "unboxed-tuples" = Right $ Set.insert UnboxedTuples+one "no-unboxed-tuples" = Right $ Set.delete UnboxedTuples+one "global-optimize" = Right $ Set.insert GlobalOptimize+one "no-global-optimize" = Right $ Set.delete GlobalOptimize+one "forall" = Right $ Set.insert Forall+one "no-forall" = Right $ Set.delete Forall+one "full-int" = Right $ Set.insert FullInt+one "no-full-int" = Right $ Set.delete FullInt+one "default" = Right $ foldr (.) id [ f | Right f <- [ one "inline-pragmas",one "rules",one "wrapper",one "defaulting",one "type-analysis",one "monomorphism-restriction",one "global-optimize",one "full-int",one "prelude"]]+one "negate" = Right $ Set.insert Negate+one "no-negate" = Right $ Set.delete Negate+one "user-kinds" = Right $ Set.insert UserKinds+one "no-user-kinds" = Right $ Set.delete UserKinds+one "glasgow-exts" = Right $ foldr (.) id [ f | Right f <- [ one "forall",one "ffi",one "unboxed-tuples"]]+one "cpp" = Right $ Set.insert Cpp+one "no-cpp" = Right $ Set.delete Cpp+one "standalone" = Right $ Set.insert Standalone+one "no-standalone" = Right $ Set.delete Standalone+one "exists" = Right $ Set.insert Exists+one "no-exists" = Right $ Set.delete Exists+one "raw" = Right $ Set.insert Raw+one "no-raw" = Right $ Set.delete Raw+one "type-analysis" = Right $ Set.insert TypeAnalysis+one "no-type-analysis" = Right $ Set.delete TypeAnalysis+one x = Left x++{-# NOINLINE process #-}+process s xs = foldr f (s,[]) (map one xs) where+   f (Right g) (s,xs) = (g s,xs)+   f (Left x) (s,xs) = (s,x:xs)++{-# NOINLINE helpMsg #-}+helpMsg = "\n-- Code options --\nbang-patterns   - bang patterns\ncpp             pass haskell source through c preprocessor\nexists          - exists keyword for existential types recognized\nffi             support foreign function declarations\nforall          - forall keyword for rank-n types and explicit\n                quantification\nm4              pass haskell source through m4 preprocessor\nprelude         implicitly import Prelude\ntype-families   type/data family support\nunboxed-tuples  allow unboxed tuple syntax to be recognized\nunboxed-values  allow unboxed value syntax\nuser-kinds      user defined kinds\n\n-- Typechecking --\ndefaulting      perform defaulting of ambiguous types\nmonomorphism-restriction enforce monomorphism restriction\n\n-- Debugging --\nlint            perform lots of extra type checks\n\n-- Optimization Options --\nglobal-optimize perform whole program E optimization\ninline-pragmas  use inline pragmas\nrules           use rules\ntype-analysis   perform a basic points-to analysis on types right after\n                method generation\n\n-- Code Generation --\nboehm           use Boehm garbage collector\ndebug           enable debugging code in generated executable\nfull-int        extend Int and Word to 32 bits on a 32 bit machine\n                (rather than 30)\njgc             use the jgc garbage collector\nprofile         enable profiling code in generated executable\nraw             just evaluate main to WHNF and nothing else.\nstandalone      compile to a standalone executable\nwrapper         wrap main in exception handler\n\n-- Default settings --\ndefault         inline-pragmas rules wrapper defaulting type-analysis\n                monomorphism-restriction global-optimize full-int\n                prelude\nglasgow-exts    forall ffi unboxed-tuples\n"+helpFlags = ["bang-patterns", "boehm", "controlled", "cpp", "debug", "default", "defaulting", "exists", "ffi", "forall", "full-int", "glasgow-exts", "global-optimize", "inline-pragmas", "jgc", "lint", "m4", "monomorphism-restriction", "negate", "prelude", "profile", "raw", "rules", "standalone", "type-analysis", "type-families", "unboxed-tuples", "unboxed-values", "user-kinds", "wrapper"]+
+ src/FrontEnd/DataConsAssump.hs view
@@ -0,0 +1,98 @@+{-------------------------------------------------------------------------------++        Copyright:              The Hatchet Team (see file Contributors)++        Module:                 DataConsAssump++        Description:            Computes the type assumptions of data+                                constructors in a module++                                For example:+                                        MyCons :: a -> MyList a+                                        Just :: a -> Maybe a+                                        True :: Bool++                                Note Well:++                                from section 4.2 of the Haskell Report:++                                "These declarations may only appear at the+                                 top level of a module."++        Primary Authors:        Bernie Pope++        Notes:                  See the file License for license information++-------------------------------------------------------------------------------}++module FrontEnd.DataConsAssump (dataConsEnv) where++import Control.Monad.Identity+import qualified Data.Map as Map++import FrontEnd.HsSyn+import FrontEnd.KindInfer+import FrontEnd.Tc.Type+import Name.Name+import Support.FreeVars++{-# NOINLINE dataConsEnv #-}+dataConsEnv :: KindEnv -> [HsDecl] -> Map.Map Name Sigma+dataConsEnv kt decls+   = Map.unions $ map (dataDeclEnv (error "dataConsenvModName") kt) decls++-- we should only apply this function to data decls and newtype decls+-- howver the fall through case is just there for completeness++dataDeclEnv :: Module -> KindEnv -> (HsDecl) -> Map.Map Name Sigma+dataDeclEnv modName kt HsDataDecl { hsDeclContext = context, hsDeclName = typeName, hsDeclArgs = args, hsDeclCons = condecls }+   = Map.unions $ map (conDeclType modName kt preds resultType) $ condecls+   where+   typeName' = toName TypeConstructor typeName+   typeKind = kindOf typeName' kt+   resultType = foldl tAp tycon argVars+   tycon = TCon (Tycon typeName' typeKind)+   argVars = map fromHsNameToTyVar $ zip argKinds args+   argKinds = init $ unfoldKind typeKind+   fromHsNameToTyVar :: (Kind, HsName) -> Type+   fromHsNameToTyVar (k, n)+      = TVar (tyvar (toName TypeVal n) k)+   preds = hsContextToPreds kt context++--dataDeclEnv modName kt (HsNewTypeDecl _sloc context typeName args condecl _)+--   = conDeclType modName kt preds resultType condecl+--   where+--   typeName' = toName TypeConstructor typeName+--   typeKind = kindOf typeName' kt+--   resultType = foldl tAp tycon argVars+--   tycon = TCon (Tycon typeName' typeKind)+--   argVars = map fromHsNameToTyVar $ zip argKinds args+--   argKinds = init $ unfoldKind typeKind+--   fromHsNameToTyVar :: (Kind, HsName) -> Type+--   fromHsNameToTyVar (k, n)+--      = TVar (tyvar (toName TypeVal n) k)+--   preds = hsContextToPreds kt context++dataDeclEnv _modName _kt _anyOtherDecl+   = Map.empty++hsContextToPreds :: KindEnv -> HsContext -> [Pred]+hsContextToPreds kt assts = map (hsAsstToPred kt) assts++-- XXX we ignore predicates on data constructors because they don't mean anything++conDeclType :: Module -> KindEnv -> [Pred] -> Type -> HsConDecl -> Map.Map Name Sigma+conDeclType modName kt preds tResult (HsConDecl { hsConDeclName = conName, hsConDeclConArg = bangTypes })+   = Map.singleton (toName DataConstructor conName) $ tForAll (freeVars qualConType) qualConType+   where+   conType = foldr fn tResult (map (bangTypeToType kt) bangTypes)+   qualConType = preds :=> conType+conDeclType modName kt preds tResult rd@HsRecDecl { hsConDeclName = conName }+   = Map.singleton (toName DataConstructor conName) $ tForAll (freeVars qualConType) qualConType+   where+   conType = foldr fn tResult (map (bangTypeToType kt) (hsConDeclArgs rd))+   qualConType = preds :=> conType++bangTypeToType :: KindEnv -> HsBangType -> Type+bangTypeToType kt (HsBangedTy t) = runIdentity $ hsTypeToType kt t+bangTypeToType kt (HsUnBangedTy t) = runIdentity $ hsTypeToType kt t
+ src/FrontEnd/DeclsDepends.hs view
@@ -0,0 +1,105 @@+{-------------------------------------------------------------------------------++        Copyright:              The Hatchet Team (see file Contributors)+        Module:                 DeclsDepends+        Description:            Collect the names that a variable declaration+                                depends upon, for use in dependency+                                analysis.+        Primary Authors:        Bernie Pope, Robert Shelton+        Notes:                  See the file License for license information++-------------------------------------------------------------------------------}++module FrontEnd.DeclsDepends (getDeclDeps, debugDeclBindGroups) where++import Control.Monad.Writer++import FrontEnd.DependAnalysis(debugBindGroups)+import FrontEnd.HsSyn+import FrontEnd.Rename(unRename)+import FrontEnd.Syn.Traverse+import FrontEnd.Utils(getDeclName)+import Name.Name++--------------------------------------------------------------------------------++-- for printing out decl bindgroups++debugDeclBindGroups :: [[HsDecl]] -> String+debugDeclBindGroups groups+   = debugBindGroups groups (show . unRename . nameName . getDeclName)+                            (nameName . getDeclName)+                            getDeclDeps++-- HsDecl getDeps function++getDeclDeps :: HsDecl -> [HsName]++getDeclDeps (HsPatBind _pat _ rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)+getDeclDeps (HsActionDecl _ _ e) = getExpDeps e+getDeclDeps (HsFunBind matches) = foldr (++) [] (map getMatchDeps matches)+getDeclDeps _ = []++getMatchDeps :: HsMatch -> [HsName]+getMatchDeps (HsMatch _sloc _name _pats rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)++-- get the dependencies from the local definitions in a function++getLocalDeclDeps :: HsDecl -> [HsName]+getLocalDeclDeps (HsFunBind matches) = foldr (++) [] (map getMatchDeps matches)++getLocalDeclDeps (HsPatBind _sloc _hspat rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)+getLocalDeclDeps (HsActionDecl _sloc _ e) = getExpDeps e++getLocalDeclDeps _ = []++-- get the dependencies from the rhs of a function++getRhsDeps :: HsRhs -> [HsName]+getRhsDeps (HsUnGuardedRhs e) = getExpDeps e+getRhsDeps (HsGuardedRhss rhss) = foldr (++) [] (map getGuardedRhsDeps rhss)++getGuardedRhsDeps :: HsGuardedRhs -> [HsName]+getGuardedRhsDeps (HsGuardedRhs _sloc guardExp rhsExp)+   = getExpDeps guardExp ++ getExpDeps rhsExp++getExpDeps :: HsExp -> [HsName]+getExpDeps e = execWriter (expDeps e)++expDeps (HsVar name) = tell [name]+expDeps (HsLet decls e) = do+    expDeps e+    tell $ foldr (++) [] (map getLocalDeclDeps decls)+expDeps (HsCase e alts) = do+    expDeps e+    tell $ foldr (++) [] (map getAltDeps alts)+expDeps (HsDo stmts) = do+    tell $ foldr (++) [] (map getStmtDeps stmts)+expDeps (HsListComp e stmts) = do+    expDeps e+    tell $ foldr (++) [] (map getStmtDeps stmts)+expDeps e = traverseHsExp_ expDeps e++getAltDeps :: HsAlt -> [HsName]++getAltDeps (HsAlt _sloc _pat guardedAlts wheres)+   = getGuardedAltsDeps guardedAlts +++     foldr (++) [] (map getLocalDeclDeps wheres)++getGuardedAltsDeps :: HsRhs -> [HsName]+getGuardedAltsDeps (HsUnGuardedRhs e) = getExpDeps e++getGuardedAltsDeps (HsGuardedRhss gAlts) = foldr (++) [] (map getGAltsDeps gAlts)++getGAltsDeps :: HsGuardedRhs -> [HsName]+getGAltsDeps (HsGuardedRhs _sloc e1 e2)+   = getExpDeps e1 +++     getExpDeps e2++getStmtDeps :: HsStmt -> [HsName]+getStmtDeps (HsGenerator _srcLoc _pat e) = getExpDeps e++getStmtDeps (HsQualifier e) = getExpDeps e++getStmtDeps (HsLetStmt decls)+   = foldr (++) [] (map getLocalDeclDeps decls)
+ src/FrontEnd/DependAnalysis.hs view
@@ -0,0 +1,283 @@+{-------------------------------------------------------------------------------++        Copyright:              The Hatchet Team (see file Contributors)++        Module:                 DependAnalysis++        Description:            Compute the dependencies between values. Can+                                be used for computing the dependencies in+                                variables and also the dependencies in types.+                                The code is used in type inference and+                                also kind inference.++        Primary Authors:        Bernie Pope, Robert Shelton++        Notes:                  See the file License for license information++-------------------------------------------------------------------------------}++module FrontEnd.DependAnalysis (getBindGroups,  debugBindGroups) where++import Data.Graph(stronglyConnComp, SCC(..))+import Data.List (nub)++-- Given a list of nodes, a function to convert nodes to a unique name, a function+-- to convert nodes to a list of names on which the node is dependendant, bindgroups+-- will return a list of bind groups generater from the list of nodes given.+getBindGroups :: Ord name =>+                 [node]           ->    -- List of nodes+                 (node -> name)   ->    -- Function to convert nodes to a unique name+                 (node -> [name]) ->    -- Function to return dependencies of this node+                 [[node]]               -- Bindgroups++getBindGroups ns fn fd = map f $ stronglyConnComp [ (n, fn n, fd n) | n <- ns] where+    f (AcyclicSCC x) = [x]+    f (CyclicSCC xs) = xs+{-+getBindGroups ns getName getDeps+	= [ mapOnList nameToNodeFM group | group <- nameGroups ]+	where+	nameGroups = buildNameGroups nameList nameEdges+	nameList = map getName ns+	nameEdges = buildNameEdges ns getName getDeps+	nameToNodeFM = listToFM [ (getName x, x) | x <- ns ]++getBindGroups ns toName getDeps = filter (not . null) (map (concatMap f) $ Scc.scc ds) where+    f n = case M.lookup n m of+        --Nothing -> error $ "cannot find " ++ show n ++ " in " ++ unlines (map show (sort ds))+        --Just x -> x+        Nothing -> fail "Nothing"+        Just x -> return x+    ds = [ (toName x, getDeps x) | x <- ns ]+    m = M.fromList [ (toName x,x) | x <- ns]+-}++--+-- Create a list of edges from a list of nodes.+--+{-+buildNameEdges :: [node]           ->    -- List of nodes+                  (node -> name)   ->    -- Function to convert nodes to a unique name+                  (node -> [name]) ->    -- Function to return dependencies of this node+                  [(name,name)]          -- Edges from list of nodes.+buildNameEdges [] _ _+	= []+buildNameEdges (n:ns) getName getDeps+	= map mapFunc (getDeps n) ++ (buildNameEdges ns getName getDeps)+	where+	mapFunc = ( \ s -> (getName n, s) )+-}++--+-- Create a list of groups from a list of names.+--+{-+buildNameGroups :: Ord name      =>+                   [name]        ->    -- list of names+                   [(name,name)] ->    -- List of edges+                   [[name]]            -- List of bindgroups+buildNameGroups ns es+	= [ mapOnList intToNameFM group | group <- intGroups ]+	where+	intGroups = map preorder $ scc $ buildG (1, sizeFM nameToIntFM) intEdges+	intEdges = mapOnTuple nameToIntFM es+	nameToIntFM = listToFM nameIntList+	intToNameFM = listToFM [ (y,x) | (x,y) <- nameIntList ]+	nameIntList = zip ns [1..]++--+-- Use a finitemap to convert a list of type A into a list of type B+-- NB, not being able to find an element in the FM is not considered+--     an error.+--+mapOnList :: Ord a         =>+             FiniteMap a b ->    -- Finite map from a to b+             [a]           ->    -- List of a+             [b]                 -- List of b+mapOnList _ [] = []+mapOnList fm (a:as)+	= case (lookupFM fm a) of+			Just b  -> b : mapOnList fm as+			Nothing -> mapOnList fm as++--+-- Use a finitemap to convert a 2 tuple to a different type.+-- NB, not being able to find an element in the FM is not considered+--     an error.+--+mapOnTuple :: Ord a         =>+              FiniteMap a b ->+              [(a,a)]       ->+              [(b,b)]+mapOnTuple _ [] = []+mapOnTuple fm ((a1,a2):as)+	= case (lookupFM fm a1) of+		Just x  ->+			case (lookupFM fm a2) of+				Just y  -> (x,y) : (mapOnTuple fm as)+				Nothing -> mapOnTuple fm as+		Nothing -> mapOnTuple fm as++-}++--------------------------------------------------------------------------------+-- showBindGroups+--------------------------------------------------------------------------------++--+-- Display bind group information in a human readable (or as close to) form.+--+{-+showBindGroups :: [[node]]        ->     -- List of nodes+		  (node->String)  ->     -- Function to convert a node to a string+                  String                 -- Printable string+showBindGroups ns getAlias+	= showBindGroups_ ns getAlias 0+-}++--+-- Recursive function which does the work of showBindGroups.+--+{-+showBindGroups_ :: [[node]]        ->     -- List of nodes+		   (node->String)  ->     -- Function to convert a node to a string+                   Int             ->     -- Bind group number+                   String                 -- Printable string+showBindGroups_ [] _ _+	= ""+showBindGroups_ (n:ns) getAlias groupNum+	= "Bindgroup " ++ show groupNum ++ " = "+	  ++ bgString ++ "\n"+	  ++ showBindGroups_ ns getAlias (groupNum + 1)+	where+	bgString = wrapString "EMPTY" (listToString n getAlias)+-}++--------------------------------------------------------------------------------+-- debugBindGroups+--------------------------------------------------------------------------------++--+-- Display bind group information in a human readable (or as close to) form.+-- Also display dependencie and error information. Warning this function is slow+-- and fat. But without forcing name to be of type Ord, it is hard to improve+-- the algorithm.+--+debugBindGroups :: (Eq name) =>+                  [[node]]        ->     -- List of nodes+		  (node->String)  ->     -- Function to produce a printable name for the node+                  (node->name)    ->     -- Function to convert nodes to a unique name+		  (node->[name])  ->     -- Function to return dependencies of this node+                  String                 -- Printable string+debugBindGroups ns getAlias getName getDeps+	= debugBindGroups_ ns getAlias getName getDeps 0 []++--+-- Recursive function which does the work of showBindGroups.+--+debugBindGroups_ :: (Eq name) =>+                   [[node]]        ->     -- List of nodes+                   (node->String)  ->     -- Function to produce a printable name for the node+                   (node->name)    ->     -- Function to convert nodes to a unique name+		   (node->[name])  ->     -- Function to return dependencies of this node+                   Int             ->     -- Bind group number+		   [(Int,[name])]  ->     -- History information of names already processed+                   String                 -- Printable string+debugBindGroups_ [] _ _ _ _ _+	= ""+debugBindGroups_ (n:ns) getAlias getName getDeps groupNum history+	= show groupNum ++ " = "+	  ++ bgString ++ "\n"+	  ++ debugBindGroups_ ns getAlias getName getDeps (groupNum + 1) newHistory+	where+	bgString = showBindGroup (expandBindGroup n getAlias getDeps newHistory)+	newHistory = history ++ [(groupNum, [ getName x | x <- n ])]++--+-- Expand bindgroups, generating dependancie and error information.+--+expandBindGroup :: (Eq name) =>+                   [node]         ->               -- List of nodes+                   (node->String) ->               -- Function to produce a printable name for the node+		   (node->[name]) ->               -- Function to return dependencies of this node+                   [(Int,[name])] ->               -- History information of names already processed+                   ([String], [Int], [String])     -- Printable string in form (bindgroup, bgnums, Errors)+expandBindGroup [] _ _ _+	= ([],[],[])+expandBindGroup (n:ns) getAlias getDeps history+	= if err+		then (name:a, bgs++b, name:c)+		else (name:a, bgs++b, c)+	where+	name = getAlias n+	(bgs, err) = inHistory (getDeps n) history+	(a,b,c) = expandBindGroup ns getAlias getDeps history+-- NB ticti, you should not be calling inHistory on the name, but instead on the deps.++--+-- Convert the information generated by expandBindGroup into a printable+-- form.+--+showBindGroup :: ([String],[Int],[String]) -> String+showBindGroup (bg, deps, errors)+	= bgString ++ " " ++ depString ++ " " ++ errString+	where+	bgString  = wrapString [] $ listToString bg id+	depString = wrapString [] $ listToString (nub deps) show+	errString = wrapString [] $ listToString errors id++--+-- Convert a list of something, into a printable string.+--+listToString :: [a]         ->    -- List of things+                (a->String) ->    -- Function to convert things to Strings+                String            -- Single printable String.+listToString [] _+	= ""+listToString [l] lFunc+	= (lFunc l)+listToString (l:ls) lFunc+	= (lFunc l) ++ ", " ++ listToString ls lFunc++--+-- Given a list of names and the history of visited names, this function+-- generates a list of bindgroups that are depended upon as well as returning+-- a boolean value indicating whether all these dependencies are satisfied.+--+-- True -> ERROR, a name needed now has not been resolved.+--+inHistory :: Eq name =>+             [name]         ->    -- List of names to be searched for+             [(Int,[name])] ->    -- History information of names already processed+             ([Int],Bool)         -- Number of bind group that name is in, or its own alias.+inHistory [] _+	= ([],False)+inHistory (name:names) history+	= if location < 0+		then (bgs, False)+		else (location : bgs, err)+	where+	location = searchHistory name history+	(bgs, err) = inHistory names history++--+-- Check whether a particular name has occured befor and return the number+-- of the bindgroup it occured in.+--+searchHistory :: Eq name        =>+                 name           ->   -- List of names to be searched for+                 [(Int,[name])] ->   -- History information of names already processed+                 Int                 -- Bindgroup num that name occurred in (-1 is error)+searchHistory _ []+	= -1+searchHistory name ((bgnum, bgnames):history)+	= if elem name bgnames+		then bgnum+		else searchHistory name history++--+-- Neatly brackets a string using a replacement string (rep) if empty.+--+wrapString :: String -> String -> String+wrapString rep "" = "[" ++ rep ++ "]"+wrapString _   s  = "[" ++ s ++ "]"
+ src/FrontEnd/Desugar.hs view
@@ -0,0 +1,309 @@+    -- various desugaring routines+--+-- The general desugaring routine creates selectors for data+-- constructors with named fields, changes all pattern bindings+-- into 'simple' pattern bindings, and adds failure cases to lambda+-- expressions which have failable patterns++module FrontEnd.Desugar (doToExp, listCompToExp, desugarHsModule, desugarHsStmt) where++import Control.Monad.State++import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse+import Name.Name+import Name.Names++type PatState = Int++getUnique = do+    n <- get+    put (n + 1)+    return n++type PatSM = State PatState++instance MonadSrcLoc PatSM where+instance MonadSetSrcLoc PatSM where+    withSrcLoc _ a = a++-- a new (unique) name introduced in pattern selector functions+newPatVarName :: HsName+newPatVarName = nameName $ toName Val ("patvar@0"::String)++{-+ this function replaces all constructor-pattern bindings in a module with+ function calls++ ie:++ (x, y) = head $ zip "abc" [1,2,3]++ becomes++ x = (\(a, _) -> a) rhs1+ y = (\(_, a) -> a) rhs1+ rhs1 = head $ zip "abc" [1,2,3]+-}++-- first argument is imported synonyms++desugarHsModule :: HsModule -> HsModule+desugarHsModule m = hsModuleDecls_s ds' m where+    (ds', _) = runState (dsm (hsModuleDecls m)) (0::Int)+    dsm ds = fmap concat $ mapM desugarDecl ds++desugarHsStmt :: Monad m => HsStmt -> m HsStmt+desugarHsStmt s = return $ fst $ runState (desugarStmt s) (0::Int)++desugarDecl :: HsDecl -> PatSM [HsDecl]+desugarDecl (HsFunBind matches) = do+    newMatches <- mapM desugarMatch matches+    return [HsFunBind newMatches]++-- variable pattern bindings remain unchanged+desugarDecl pb@(HsPatBind sloc (HsPVar n) rhs wheres) = do+    newRhs <- desugarRhs rhs+    newWheres <- mapM desugarDecl wheres+    return [HsPatBind sloc (HsPVar n) newRhs (concat newWheres)]++desugarDecl pb@(HsPatBind sloc pat rhs wheres) = do+    rhs <- desugarRhs rhs+    unique <- getUnique+    let newRhsName = toName Val ("patrhs@" ++ show unique)+    newWheres <- mapM desugarDecl wheres+    let newTopDeclForRhs+               = HsPatBind sloc (HsPVar newRhsName) rhs (concat newWheres)+    let newBinds = genBindsForPat pat sloc newRhsName+    newBinds <- mapM desugarDecl newBinds+    return (newTopDeclForRhs : concat newBinds)++desugarDecl (HsClassDecl sloc qualtype decls) = do+    newDecls <- mapM desugarDecl decls+    return [HsClassDecl sloc qualtype (concat newDecls)]++desugarDecl (HsInstDecl sloc qualtype decls) = do+    newDecls <- mapM desugarDecl decls+    return [HsInstDecl sloc qualtype (concat newDecls)]++-- XXX we currently discard instance specializations+desugarDecl HsPragmaSpecialize { hsDeclName = n } | n == u_instance = return []++desugarDecl anyOtherDecl = return [anyOtherDecl]++desugarMatch :: (HsMatch) -> PatSM (HsMatch)+desugarMatch (HsMatch sloc funName pats rhs wheres) = do+        newWheres <- mapM desugarDecl wheres+        newRhs <- desugarRhs rhs+        return (HsMatch sloc funName pats newRhs (concat newWheres))++-- generate the pattern bindings for each variable in a pattern++genBindsForPat :: HsPat -> SrcLoc -> HsName -> [HsDecl]+genBindsForPat pat sloc rhsName+   = [HsPatBind sloc (HsPVar patName) (HsUnGuardedRhs (HsApp selector (HsVar rhsName))) [] |  (patName, selector) <- selFuns]+   where+   selFuns = getPatSelFuns sloc pat++-- generate selector functions for each of the variables that+-- are bound in a pattern++getPatSelFuns :: SrcLoc -> HsPat -> [(HsName, (HsExp))]+getPatSelFuns sloc pat = [(varName, HsParen (HsLambda sloc [HsPVar newPatVarName] (kase (replaceVarNamesInPat varName pat)))) | varName <- getNamesFromHsPat pat] where+    kase p =  HsCase (HsVar newPatVarName) [a1, a2 ] where+       a1 =  HsAlt sloc p (HsUnGuardedRhs (HsVar newPatVarName)) []+       a2 =  HsAlt sloc HsPWildCard (HsUnGuardedRhs (HsError { hsExpSrcLoc = sloc, hsExpErrorType = HsErrorPatternFailure, hsExpString = show sloc ++ " failed pattern match" })) []+       --a2 =  HsAlt sloc HsPWildCard (HsUnGuardedRhs (HsApp (HsVar (toName Val ("error"::String))) (HsLit $ HsString $ show sloc ++ " failed pattern match"))) []++-- replaces all occurrences of a name with a new variable+-- and every other name with underscore++replaceVarNamesInPat :: HsName -> HsPat -> HsPat+replaceVarNamesInPat name p = f name p where+    f name1 (HsPVar (toName Val -> name2))+       | name1 == name2 = HsPVar $ newPatVarName+       | otherwise = HsPWildCard+    f _ p@(HsPLit _) = p+    f name (HsPNeg pat) = HsPNeg $ f name pat+    f name (HsPInfixApp pat1 conName pat2) = HsPInfixApp (f name pat1) conName (f name pat2)+    f name (HsPApp conName pats) = HsPApp conName (map (f name) pats)+    f name (HsPTuple pats) = HsPTuple (map (f name) pats)+    f name (HsPUnboxedTuple pats) = HsPUnboxedTuple (map (f name) pats)+    f name (HsPList pats) = HsPList (map (f name) pats)+    f name (HsPParen pat) = HsPParen (f name pat)+    f name (HsPRec conName fields) = HsPRec conName [ HsPFieldPat fname (f name pat)+                                                      | HsPFieldPat fname pat <- fields ]+    f name (HsPAsPat asName pat)+       | name == asName = HsPAsPat newPatVarName (f name pat)+       | otherwise = f name pat+    f name HsPWildCard = HsPWildCard+    f name (HsPIrrPat pat) = HsPIrrPat $ fmap (f name) pat+    f name (HsPBangPat pat) = HsPBangPat $ fmap (f name) pat+    f name p = error $ "f: " ++ show (name,p)++desugarRhs :: (HsRhs) -> PatSM (HsRhs)+desugarRhs  = traverseHsRhsHsExp desugarExp++desugarExp :: (HsExp) -> PatSM (HsExp)+desugarExp (HsLambda sloc pats e)+    | all isSimplePat pats  = do+        newE <- desugarExp e+        return (HsLambda sloc pats newE)+desugarExp (HsLambda sloc pats e) = z where+    z = do+        ps <- mapM f pats+        let (xs,zs) = unzip ps+        e' <- (ne e $ concat zs)+        return (HsLambda sloc (map HsPVar xs) e')+    ne e [] = desugarExp e+    ne e ((n,p):zs) =  do+        e' <- ne e zs+        let a1 =  HsAlt sloc p (HsUnGuardedRhs e') []+            a2 =  HsAlt sloc HsPWildCard (HsUnGuardedRhs (HsError { hsExpSrcLoc = sloc, hsExpErrorType = HsErrorPatternFailure, hsExpString = show sloc ++ " failed pattern match in lambda" })) []+        return $ HsCase (HsVar n) [a1, a2 ]++    f (HsPVar x) = return (x,[])+    f (HsPAsPat n p) = return (n,[(n,p)])+    f p = do+        unique <- getUnique+        let n = nameName $ toName Val ("lambind@" ++ show unique)+        return (n,[(n,p)])+desugarExp (HsLet decls e) = do+        newDecls <- mapM desugarDecl decls+        newE <- desugarExp e+        return (HsLet (concat newDecls) newE)+desugarExp (HsCase e alts) = do+        newE <- desugarExp e+        newAlts <- mapM desugarAlt alts+        return (HsCase newE newAlts)+desugarExp (HsDo stmts) = HsDo `liftM` mapM desugarStmt stmts+desugarExp (HsListComp e stmts) = do+        e <- desugarExp e+        stmts <- mapM desugarStmt stmts+        return (HsListComp e stmts)+desugarExp e = traverseHsExp desugarExp e++desugarAlt :: (HsAlt) -> PatSM (HsAlt)+desugarAlt (HsAlt sloc pat gAlts wheres) = do+        newGAlts <- desugarRhs gAlts+        newWheres <- mapM desugarDecl wheres+        return (HsAlt sloc pat newGAlts (concat newWheres))++desugarStmt :: (HsStmt) -> PatSM (HsStmt)+desugarStmt (HsGenerator srcLoc pat e) = do+        newE <- desugarExp e+        return (HsGenerator srcLoc pat newE)+desugarStmt (HsQualifier e) = do+        newE <- desugarExp e+        return (HsQualifier newE)+desugarStmt (HsLetStmt decls) = do+        newDecls <- mapM desugarDecl decls+        return (HsLetStmt $ concat newDecls)++doToExp :: Monad m+    => m HsName    -- ^ name generator+    -> HsName      -- ^ bind (>>=) to use+    -> HsName      -- ^ bind_ (>>) to use+    -> HsName      -- ^ fail to use+    -> [HsStmt]+    -> m HsExp+doToExp newName f_bind f_bind_ f_fail ss = hsParen `liftM` f ss where+    f [] = fail "doToExp: empty statements in do notation"+    f [HsQualifier e] = return e+    f [gen@(HsGenerator srcLoc _pat _e)] = fail $ "doToExp: last expression n do notation is a generator (srcLoc):" ++ show srcLoc+    f [letst@(HsLetStmt _decls)] = fail $ "doToExp: last expression n do notation is a let statement"+    f (HsQualifier e:ss) = do+        ss <- f ss+        return $ HsInfixApp (hsParen e) (HsVar f_bind_) (hsParen ss)+    f ((HsGenerator _srcLoc pat e):ss) | isSimplePat pat = do+        ss <- f ss+        return $ HsInfixApp (hsParen e) (HsVar f_bind) (HsLambda _srcLoc [pat] ss)+    f ((HsGenerator srcLoc pat e):ss) = do+        npvar <- newName+        ss <- f ss+        let kase = HsCase (HsVar npvar) [a1, a2 ]+            a1 =  HsAlt srcLoc pat (HsUnGuardedRhs ss) []+            a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedRhs (HsApp (HsVar f_fail) (HsLit $ HsString $ show srcLoc ++ " failed pattern match in do"))) []+        return $ HsInfixApp (hsParen e) (HsVar f_bind) (HsLambda srcLoc [HsPVar npvar] kase)  where+    f (HsLetStmt decls:ss) = do+        ss <- f ss+        return $ HsLet decls ss++hsApp e es = hsParen $ foldl HsApp (hsParen e) (map hsParen es)+hsIf e a b = hsParen $ HsIf e a b++listCompToExp :: Monad m => m HsName -> HsExp -> [HsStmt] -> m HsExp+listCompToExp newName exp ss = hsParen `liftM` f ss where+    f [] = return $ HsList [exp]+    f (gen:HsQualifier q1:HsQualifier q2:ss)  = f (gen:HsQualifier (hsApp (HsVar v_and) [q1,q2]):ss)+    f ((HsLetStmt ds):ss) = do ss' <- f ss; return $ hsParen (HsLet ds ss')+    f (HsQualifier e:ss) = do ss' <- f ss; return $ hsParen (HsIf e ss' (HsList []))+    f ((HsGenerator srcLoc pat e):ss) | isLazyPat pat, Just exp' <- g ss = do+        return $ hsParen $ HsVar v_map `app` HsLambda srcLoc [pat] exp' `app` e+    --f ((HsGenerator srcLoc pat e):[HsQualifier q]) | isHsPVar pat = hsParen $ HsApp (HsApp (HsVar f_filter)  (hsParen $ HsLambda srcLoc [pat] q) ) e+    f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isLazyPat pat, Just exp' <- g ss = do+        npvar <- newName+        return $ hsApp (HsVar v_foldr)  [HsLambda srcLoc [pat,HsPVar npvar] $ hsIf q (hsApp (HsCon dc_Cons) [exp',HsVar npvar]) (HsVar npvar), HsList [],e]+    f ((HsGenerator srcLoc pat e):ss) | isLazyPat pat = do+        ss' <- f ss+        return $ hsParen $ HsVar v_concatMap `app`  HsLambda srcLoc [pat] ss' `app` e+    f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isFailablePat pat || Nothing == g ss = do+        npvar <- newName+        ss' <- f ss+        let kase = HsCase (HsVar npvar) [a1, a2 ]+            a1 =  HsAlt srcLoc pat (HsGuardedRhss [HsGuardedRhs srcLoc q ss']) []+            a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedRhs $ HsList []) []+        return $ hsParen $ HsVar v_concatMap `app`  HsLambda srcLoc [HsPVar npvar] kase `app`  e+    f ((HsGenerator srcLoc pat e):ss) | isFailablePat pat || Nothing == g ss = do+        npvar <- newName+        ss' <- f ss+        let kase = HsCase (HsVar npvar) [a1, a2 ]+            a1 =  HsAlt srcLoc pat (HsUnGuardedRhs ss') []+            a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedRhs $ HsList []) []+        return $ hsParen $ HsVar v_concatMap `app` HsLambda srcLoc [HsPVar npvar] kase `app` e+    f ((HsGenerator srcLoc pat e):ss) = do+        npvar <- newName+        let Just exp' = g ss+            kase = HsCase (HsVar npvar) [a1 ]+            a1 =  HsAlt srcLoc pat (HsUnGuardedRhs exp') []+        return $ hsParen $ HsVar v_map `app` HsLambda srcLoc [HsPVar npvar] kase `app` e+    g [] = return exp+    g (HsLetStmt ds:ss) = do+        e <- g ss+        return (hsParen (HsLet ds e))+    g _ = Nothing+    app x y = HsApp x (hsParen y)++-- patterns are+-- failable - strict and may fail to match+-- refutable or strict - may bottom out+-- irrefutable or lazy - match no matter what+-- simple, a wildcard or variable+-- failable is a subset of refutable++isFailablePat p | isStrictPat p = f (openPat p) where+    f (HsPTuple ps) = any isFailablePat ps+    f (HsPUnboxedTuple ps) = any isFailablePat ps+    f (HsPBangPat (Located _ p)) = isFailablePat p+    f _ = True+isFailablePat _ = False++isSimplePat p = f (openPat p) where+    f HsPVar {} = True+    f HsPWildCard = True+    f _ = False++isLazyPat pat = not (isStrictPat pat)+isStrictPat p = f (openPat p) where+    f HsPVar {} = False+    f HsPWildCard = False+    f (HsPIrrPat p) = False -- isStrictPat p  -- TODO irrefutable patterns+    f _ = True++openPat (HsPParen p) = openPat p+openPat (HsPNeg p) = openPat p+openPat (HsPAsPat _ p) = openPat p+openPat (HsPTypeSig _ p _) = openPat p+openPat (HsPInfixApp a n b) = HsPApp n [a,b]+openPat p = p
+ src/FrontEnd/Diagnostic.hs view
@@ -0,0 +1,123 @@+{-------------------------------------------------------------------------------++        Copyright:              The Hatchet Team (see file Contributors)++        Module:                 Diagnostic++        Description:            Utilities for working with (error/otherwise)+                                diagnostics.++        Primary Authors:        Bryn Humberstone++        Notes:                  See the file License for license information++-------------------------------------------------------------------------------}++module FrontEnd.Diagnostic (+       Diagnostic(..),+       makeMsg,+       locMsg,+       locSimple,+       simpleMsg,+       dumpDiagnostic,+       typeError,+       TypeError (..),+       ) where++import Data.List as List(find)+import Data.Maybe (isJust)+import Data.Monoid++import FrontEnd.SrcLoc+import PackedString++data TypeError+        = Unification String+        | Failure String++typeError :: Monad m => TypeError -> [Diagnostic] -> m a+typeError err ds+   = fail $ "\n" +++             "What:    " ++ whatStr ++ "\n" +++             "Why:     " ++ whyStr ++ "\n" +++             "Where:   " ++ dumpDiagnostic 3 ds+   where+   (whatStr, whyStr) =+        case err of+           Unification s -> ("type unification error", s)+           Failure s ->  ("failure", s)++data Diagnostic = Msg (Maybe SrcLoc) String+   deriving Show++{- Little helper functions for keeping good error contexts around -}+type Description = String++{- given a description, make a Diagnostic out of it -}+simpleMsg :: Description -> Diagnostic+simpleMsg description+   = Msg Nothing description++{- given a description and some data to be shown make a diagnostic -}+-- makeMsg :: PrettyShow a => Description -> a -> Diagnostic+makeMsg :: Description -> String -> Diagnostic+makeMsg description val+   = simpleMsg (description ++ "\n   " ++ val)++{- given a srcloc and a description, make a diagnostic -}+locSimple :: SrcLoc -> Description -> Diagnostic+locSimple loc desc = withASrcLoc loc (simpleMsg desc)++{- like locSimple but also takes data to be displayed -}+-- locMsg :: PrettyShow a => SrcLoc -> Description -> a -> Diagnostic+locMsg :: SrcLoc -> Description -> String -> Diagnostic+locMsg loc desc val = locSimple loc (desc ++ "\n   " ++ val)++{- take a diagnostic stack and a 'maxContext' and display the+   most recent maxContext number of lines from the stack -}+dumpDiagnostic :: Int -> [Diagnostic] -> String+dumpDiagnostic maxContext diagnostics+   = mostRecentASrcLoc ++ "\n"+      -- ++ (showDiagnostics . reverse . take maxContext $ diagnostics)+      ++ (showDiagnostics . take maxContext $ diagnostics)+   where+     hasASrcLoc diag+         = case diag of+                Msg maybeloc _ -> isJust maybeloc+           --   _ -> False++     mostRecentASrcLoc+         = case List.find hasASrcLoc diagnostics of+                Just (Msg (Just (SrcLoc fn line col)) _)+                    -> "on line " ++ show line ++ " in " ++ unpackPS fn+                _ -> "no line information"++{- display an entire stack of diagnostics (it displays the top of+   the stack first, so most calls will have to reverse the stack+   before getting here -}+showDiagnostics :: [Diagnostic] -> String+showDiagnostics diags+    = case diags of+        [onlyOne] -> "The error was " ++ showDiag onlyOne+        _         -> showDiagnostics' diags+    where+    showDiagnostics' [] = ""+    showDiagnostics' (diag:diags)+       = case diags of+         --[] -> "\nSo the error was " ++ showDiag diag  -- innermost error+         [] -> showDiag diag  -- innermost error+         _  -> showDiag diag ++ "\n" ++ showDiagnostics' diags++    showDiag (Msg maybeLoc msg)+       = msg+         {- I think that all these line numbers are probably excessive -}+         ++ case maybeLoc of+              Just srcloc -> "\t\t{- on line " ++ show (srcLine srcloc) ++ " -}"  -- discreetly display line nums+              _ -> ""++srcLine :: SrcLoc -> Int+srcLine = srcLocLine++withASrcLoc :: SrcLoc -> Diagnostic -> Diagnostic+withASrcLoc loc x | loc == mempty = x+withASrcLoc loc (Msg _ description) = Msg (Just loc) description
+ src/FrontEnd/Exports.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DoRec,NoMonoLocalBinds #-}+-- | determine export\/imports for modules via fixpoint recursion++module FrontEnd.Exports(determineExports,ModInfo(..)) where++import Control.Monad.Identity+import Data.List+import Data.Maybe+import Data.Monoid(Monoid(..))+import qualified Data.Map as Map+import qualified Data.Set as Set++import Doc.DocLike+import FindFixpoint+import FlagDump as FD+import FlagOpts as FO+import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import FrontEnd.Warning+import Name.Name as Name+import Options+import Util.Relation as R+import Util.SetLike as SL++data ModInfo = ModInfo {+    modInfoName       :: Module,+    modInfoDefs       :: [(Name,SrcLoc,[Name])],+    modInfoConsArity  :: [(Name,Int)],+    modInfoExport     :: [Name],+    modInfoImport     :: [(Name,[Name])],+    modInfoHsModule   :: HsModule,+    modInfoReverseMap :: Map.Map Name Name,+    modInfoOptions    :: Opt+    }++instance Eq ModInfo where+    a == b = modInfoName a == modInfoName b++instance Ord ModInfo where+    compare a b = compare (modInfoName a) (modInfoName b)++modInfoModImports m =  mp  [ i | i <- hsModuleImports (modInfoHsModule m)] where+    mp xs+        | any ((== toModule "Prelude") . hsImportDeclModule) xs = xs+        | FO.Prelude `Set.member` (optFOptsSet $ modInfoOptions m) = (prelude:xs)+        | otherwise = xs+    prelude = HsImportDecl {+        hsImportDeclSrcLoc = bogusASrcLoc,+        hsImportDeclModule = toModule "Prelude",+        hsImportDeclSpec = Nothing,+        hsImportDeclAs = Nothing,+        hsImportDeclQualified = False }++--doExports :: [(Module,[Name])] -> [[ModInfo]] -> [[ModInfo]] -> IO [[ModInfo]]++determineExports :: [(Name,SrcLoc,[Name])] -> [(Module,[Name])] -> [ModInfo]  -> IO [ModInfo]+determineExports defs ae ms = do+    --wdump FD.Progress $ do+    --    putErrLn $ "Determining Exports/Imports: " ++ show (sort [ m | m <- map modInfoName ms])+        --mapM_ CharIO.print [ (modInfoName m, map hsImportDeclModule $ modInfoModImports m) | m <- ms]+    let ds = [ (n,cs) | (n,_,cs) <- defs ++ concatMap modInfoDefs ms]+    ms <- determineExports' ds ae ms+    let g m = do+            when (dump FD.Imports) $ do+                putStrLn $ " -- Imports: " ++ show (modInfoName m)+                putStr $ unlines  (sort $ map show (modInfoImport m))+            when (dump FD.Exports) $ do+                putStrLn $ " -- Exports: " ++ show (modInfoName m)+                mapM_ putStrLn (sort [ show (nameType n) ++ " " ++ show n | n <- modInfoExport m])+    mapM_ g ms+    processIOErrors+    return ms++determineExports' :: [(Name,[Name])] -> [(Module,[Name])] -> [ModInfo] -> IO [ModInfo]+determineExports' owns doneMods todoMods = mdo+    rs <- solve Nothing  mempty [ x |(_,_,x) <- ms]+    let lf m = maybe (fail $ "determineExports'.lf: " ++ show m) return $  Map.lookup m  $ dmodMap `mappend` Map.fromList [ (modInfoName x,fromList [(toUnqualified x,x) | x <- modInfoExport x]) |  x  <- xs]+    let g  (mi,ne) = do+            ne' <- ce mi ne+            return mi { modInfoExport = ne', modInfoImport = toRelationList $ runIdentity $  getImports mi lf  }+    xs <- mapM g $ zip todoMods rs+    return xs+    where+    ms = [ (i,mi, getExports mi le ) | mi <- todoMods | i <- [0..]]+    dmodMap = Map.fromList  [ ( x,fromList [(toUnqualified n,n) | n <- xs]) |  (x,xs) <- doneMods ]+    modMap = fmap return dmodMap `mappend` (Map.fromList [ (modInfoName n,getVal i) | (i,n,_) <- ms])+    ownsMap = Map.fromList owns+    le m = runIdentity $ maybe (fail $ "determineExports'.le: " ++ show m) return $ Map.lookup m modMap+    ce m x = mapM f (toRelationList x) where+        f (x,[y]) = return y+        f (_,[]) = error "can't happen"+        f (x,ys) = warn bogusASrcLoc (AmbiguousExport (modInfoName m) ys) ("module " <> fromModule (modInfoName m) <> " has ambiguous exports: " ++ show ys) >> return (head ys)++    getExports :: Monad m => ModInfo -> (Module -> m (Rel Name Name)) -> m (Rel Name Name)+    getExports mi@ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing } } _ = return $ defsToRel (modInfoDefs mi)+    getExports mi le | HsModule { hsModuleExports = Just es } <- modInfoHsModule mi = do+        is <- getImports mi le+        let f (HsEModuleContents m) = mapDomain g unqs `intersection` qs where+                (qs,unqs) = partitionDomain (isJust . getModule ) is+                g x = Name.qualifyName m x+            f z = entSpec False is z+        return $ mapDomain toUnqualified (unions $ map f es)+    getExports _ _ = error "Exports.getExports: bad."++    -- | determine what is visible in a module+    getImports :: Monad m => ModInfo -> (Module -> m (Rel Name Name)) -> m (Rel Name Name)+    getImports mi le = mapM f is >>= \xs -> return (mconcat (ls:xs))  where+        f x = do+            es <- le (hsImportDeclModule x)+            Just as <- return $  hsImportDeclAs x `mplus` Just (hsImportDeclModule x)+            es' <- case hsImportDeclSpec x of+                Nothing -> return es -- return $ (mapDomain ((Name.qualifyName as)) es `mappend` if hsImportDeclQualified x then mempty else es)+                Just (isHiding,xs) -> do+                    let listed = mconcat $ map (entSpec isHiding es) xs+                    return $ if isHiding then es SL.\\ listed else listed+            return $ (mapDomain ((Name.qualifyName as)) es' `mappend` if hsImportDeclQualified x then mempty else es')+        is = modInfoModImports mi+        ls = fromList $  concat [ [(toUnqualified z,z),(z,z)]| (z, _, _) <- modInfoDefs mi]++    entSpec ::+        Bool              -- ^ is it a hiding import?+        -> Rel Name Name  -- ^ the original relation+        -> HsExportSpec   -- ^ the specification+        -> Rel Name Name  -- ^ the subset satisfying the specification+    entSpec isHiding rel e = f Nothing e where+	f _ (HsEVar n) = restrictDomainS (toName Val n) rel+	f Nothing (HsEAbs n) = restrictDomainSet (Set.fromList [ toName x n | x <- ts]) rel  where+	    ts = TypeConstructor:ClassName:if isHiding then [DataConstructor] else []+	f (Just nt) (HsEAbs n) = restrictDomainSet (Set.singleton (toName nt n)) rel  where+	f mnt (HsEThingWith n xs) = restrictDomainSet (fromList (concat (map (`toName` n) ct:(map cd xs)))) rel where+	    ct = case mnt of+		Nothing -> [TypeConstructor,ClassName]+		Just nt -> [nt]+	    cd n =  [toName DataConstructor n, toName Val n, toName FieldLabel n ]+	f mnt (HsEThingAll n) = rdl `mappend` restrictRange (`elem` ss) rel where+	    ct = case mnt of+		Nothing -> [TypeConstructor,ClassName]+		Just nt -> [nt]+	    ss = concat $ concat [ maybeToList (Map.lookup x ownsMap) | x <- Set.toList $ range rdl ]+	    --cd n = [toName DataConstructor n, toName Val n, toName FieldLabel n ]+	    rdl = (restrictDomain (`elem` map (`toName` n) ct) rel)+	f _ (HsEQualified t n) = f (Just t) n+        f _ _ = error "Export.determineExports': bad."++defsToRel xs = fromList $ map f xs where+    f (n,_,_) = (toUnqualified n,n)
+ src/FrontEnd/FrontEnd.hs view
@@ -0,0 +1,40 @@+module FrontEnd.FrontEnd(+    doModules,+    Tc.TiData(..)+    ) where++import Control.Monad+import qualified Data.Map as Map++import Doc.DocLike+import FrontEnd.Exports+import FrontEnd.HsSyn+import FrontEnd.Rename+import Ho.Type+import Options+import qualified FlagDump as FD+import qualified FrontEnd.Tc.Module as Tc++-- Process modules found by Ho+doModules :: HoTcInfo -> [HsModule] -> IO  (HoTcInfo,Tc.TiData)+doModules htc ms  = do+    ms <- mapM modInfo ms+    when (dump FD.Defs) $ flip mapM_ ms $ \m -> do+         putStrLn $ " ---- Definitions for" <+> show (modInfoName m) <+> "----"+         mapM_ print (modInfoDefs m)+    ms <- determineExports [ (x,y,z) |+        (x,(y,z)) <- Map.toList $ hoDefs htc] (Map.toList $ hoExports htc) ms+    Tc.tiModules htc ms++modInfo m = do+    let (xs,ys) = collectDefsHsModule m+    return ModInfo {+        modInfoName = hsModuleName m,+        modInfoDefs = xs,+        modInfoHsModule = m,+        modInfoConsArity = ys,+        modInfoExport = error "modInfoExport",+        modInfoImport = error "modInfoImport",+        modInfoReverseMap = error "modInfoReverseMap",+        modInfoOptions = hsModuleOpt m+        }
+ src/FrontEnd/HsErrors.hs view
@@ -0,0 +1,88 @@+-- Routines to check for several error and warning conditions which can be+-- locally determined from syntax.+module FrontEnd.HsErrors(+    hsType,+    hsDeclTopLevel,+    hsDeclLocal+    ) where++import FrontEnd.Class+import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse+import FrontEnd.Warning+import Name.Name++hsType :: (MonadSrcLoc m, MonadWarn m) => HsType -> m ()+--hsType x@HsTyForall {} = do+--    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"+--    hsQualType (hsTypeType x)+--hsType x@HsTyExists {} = do+--    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"+--    hsQualType (hsTypeType x)+hsType x = traverseHsType (\x -> hsType x >> return x) x >> return ()++--hsQualType x  = hsType (hsQualTypeType x)++data Context = InClass [HsType] | InInstance [HsType] | TopLevel | Local+    deriving(Eq)++instance Show Context where+    show InClass {} = "in a class declaration"+    show InInstance {} = "in an instance declaration"+    show TopLevel = "at the top level"+    show Local = "in local declaration block"++hsDeclTopLevel,hsDeclLocal :: MonadWarn m => HsDecl -> m ()+hsDeclTopLevel = hsDecl TopLevel+hsDeclLocal = hsDecl Local++hsDecl :: MonadWarn m => Context -> HsDecl -> m ()+hsDecl cntx decl = f cntx decl where+    f _ d@HsTypeFamilyDecl { } = do+        warn (srcLoc d) UnsupportedFeature "Type families currently not supported"+    f l d@HsTypeDecl { } | l /= TopLevel= do+        warn (srcLoc d) UnsupportedFeature "Type families currently not supported"+    f TopLevel HsDataDecl { hsDeclSrcLoc = sl, hsDeclCons = cs, hsDeclDerives = ds' } = do+        let ds = map (toName ClassName) ds'+--        when (null cs) $ warn sl "h98-emptydata" "data types with no constructors are a non-haskell98 feature"+        checkDeriving sl False ds+--        let isEnum = all (\x ->  null (hsConDeclArgs x)) cs+--        when (not isEnum && class_Enum `elem` ds) $ warn sl "derive-enum" "Cannot derive enum from non enumeration type"+--        when (not isEnum && length cs /= 1 && class_Bounded `elem` ds) $ warn sl "derive-bounded" "Cannot derive bounded from non enumeration or unary type"+        return ()+--    f TopLevel HsNewTypeDecl { hsDeclSrcLoc = sl, hsDeclDerives = ds' } = do+--        let ds = map (toName ClassName) ds'+--        checkDeriving sl True ds+--        return ()+    f context@TopLevel decl@HsTypeDecl { hsDeclTArgs = as } | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context+--    f context@(InClass ts) decl@HsTypeDecl { hsDeclTArgs = as }+--        | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context+    --    | length as < length ts || or (zipWith (/=) as ts) = warn (srcLoc decl) "invalid-assoc" $ "arguments to associated type must match class decl" ++ show (as,ts)+    f context@(InInstance ts) decl@HsTypeDecl { hsDeclTArgs = as }+    --    | length as < length ts || or (zipWith (==) as ts) = warn (srcLoc decl) "invalid-assoc" $ "arguments to associated type must match instance head"+        | any (not . isHsTyVar) (drop (length ts) as) = warn (srcLoc decl) InvalidDecl $ "extra complex type arguments not allowed " ++ show context+    f context decl@HsDataDecl {} = warn (srcLoc decl) InvalidDecl $ "data declaration not allowed " ++ show context+--    f context decl@HsNewTypeDecl {} = warn (srcLoc decl) InvalidDecl $ "newtype declaration not allowed " ++ show context+--    f TopLevel decl@HsClassDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InClass args)) decls+    f TopLevel decl@HsClassDecl { hsDeclClassHead = ch, hsDeclDecls = decls } = do mapM_ (f (InClass (hsClassHeadArgs ch))) decls+    f TopLevel decl@HsInstDecl { hsDeclClassHead = ch, hsDeclDecls = decls } = do mapM_ (f (InInstance (hsClassHeadArgs ch))) decls+    --f TopLevel decl@HsInstDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InInstance args)) decls+    f context decl@HsClassDecl {} = warn (srcLoc decl) InvalidDecl $ "class declaration not allowed " ++ show context+    f context decl@HsInstDecl {} = warn (srcLoc decl) InvalidDecl $ "instance declaration not allowed " ++ show context++    f _ _ = return ()++--fetchQtArgs sl HsQualType { hsQualTypeType = t } | (HsTyCon {},args@(_:_)) <- fromHsTypeApp t = return args+--fetchQtArgs sl _ = warn sl InvalidDecl "invalid head in class or instance decl" >> return []++checkDeriving _ _ xs | all (`elem` derivableClasses) xs = return ()+--checkDeriving sl True _ = warn sl "h98-newtypederiv" "arbitrary newtype derivations are a non-haskell98 feature"+checkDeriving sl False xs+  = let nonDerivable = filter (`notElem` derivableClasses) xs+    in warn sl (UnknownDeriving nonDerivable) ("attempt to derive from a non-derivable class: " ++ unwords (map show nonDerivable))+checkDeriving _ True _ = error "HsErrors.checkDeriving: bad."++--fromHsTypeApp t = f t [] where+--    f (HsTyApp a b) rs = f a (b:rs)+--    f t rs = (t,rs)
+ src/FrontEnd/HsParser.y view
@@ -0,0 +1,1118 @@+{-# OPTIONS_GHC -w -XNoOverloadedStrings #-} {- -*- Haskell -*- -}+-- -----------------------------------------------------------------------------+-- $Id: HsParser.ly,v 1.4 2001/11/25 08:52:13 bjpop Exp $++-- (c) Simon Marlow, Sven Panne 1997-2000+-- Modified by John Meacham++-- Haskell grammar.+-- -----------------------------------------------------------------------------++-- ToDo: Is (,) valid as exports? We don't allow it.+-- ToDo: Check exactly which names must be qualified with Prelude (commas and friends)+-- ToDo: Inst (MPCs?)+-- ToDo: Polish constr a bit+-- ToDo: Ugly: infixexp is used for lhs, pat, exp0, ...+-- ToDo: Differentiate between record updates and labeled construction.++{+module FrontEnd.HsParser (parse, parseHsStmt) where++import FrontEnd.HsSyn+import FrontEnd.ParseMonad+import FrontEnd.Lexer+import FrontEnd.ParseUtils hiding(readInteger,readRational)+import FrontEnd.SrcLoc++import Name.Names+import Name.Name++import Control.Monad (liftM, liftM2)+import Debug.Trace (trace)++}++-- -----------------------------------------------------------------------------+-- Conflicts: 10 shift/reduce++-- 7 for abiguity in 'if x then y else z + 1'+--      (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)+-- 1 for ambiguity in 'if x then y else z :: T'+--      (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)+-- 2 for ambiguity in 'case x of y :: a -> b'+--      (don't know whether to reduce 'a' as a btype or shift the '->'.+--       conclusion:  bogus expression anyway, doesn't matter)++-- -----------------------------------------------------------------------------++%token+      VARID    { VarId $$ }+      QVARID   { QVarId $$ }+      CONID    { ConId $$ }+      QCONID   { QConId $$ }+      VARSYM   { VarSym $$ }+      CONSYM   { ConSym $$ }+      QVARSYM  { QVarSym $$ }+      QCONSYM  { QConSym $$ }+      INT      { IntTok $$ }+      UINT     { UIntTok $$ }+      RATIONAL { FloatTok $$ }+      CHAR     { Character $$ }+      UCHAR    { UCharacter $$ }+      STRING   { StringTok $$ }+      USTRING  { UStringTok $$ }+      PRAGMAOPTIONS { PragmaOptions $$ }+      PRAGMASTART { PragmaStart $$ }+      PRAGMACTYPE { PragmaExp "CTYPE" }+      PRAGMAINLINE { PragmaInline $$ }+      PRAGMARULES { PragmaRules $$ }+      PRAGMASPECIALIZE { PragmaSpecialize $$ }+      PRAGMAEND { PragmaEnd }++-- Symbols++      '('     { LeftParen }+      ')'     { RightParen }+      '(#'    { LeftUParen }+      '#)'    { RightUParen }+      ';'     { SemiColon }+      '{'     { LeftCurly }+      '}'     { RightCurly }+      vccurly { VRightCurly }                 -- a virtual close brace+      '['     { LeftSquare }+      ']'     { RightSquare }+      ','     { Comma }+      '_'     { Underscore }+      '`'     { BackQuote }++-- Reserved operators++      '..'    { DotDot }+      '::'    { DoubleColon }+      '='     { Equals }+      '\\'    { Backslash }+      '|'     { Bar }+      '<-'    { LeftArrow }+      '->'    { RightArrow }+      '@'     { At }+      '~'     { Tilde }+      '=>'    { DoubleArrow }+      '-'     { Minus }+      '!'     { Exclamation }+      'bang!' { BangExclamation }+      '?'     { Quest }+      '??'    { QuestQuest }+      '*!'    { StarBang }+      '*'     { Star }+      '#'     { Hash }+      '.'     { Dot }++-- Reserved Ids++      'as'            { KW_As }+      'case'          { KW_Case }+      'class'         { KW_Class }+      'alias'         { KW_Alias }+      'data'          { KW_Data }+      'default'       { KW_Default }+      'deriving'      { KW_Deriving }+      'do'            { KW_Do }+      'else'          { KW_Else }+      'hiding'        { KW_Hiding }+      'if'            { KW_If }+      'import'        { KW_Import }+      'in'            { KW_In }+      'infix'         { KW_Infix }+      'infixl'        { KW_InfixL }+      'infixr'        { KW_InfixR }+      'instance'      { KW_Instance }+      'let'           { KW_Let }+      'module'        { KW_Module }+      'newtype'       { KW_NewType }+      'of'            { KW_Of }+      'then'          { KW_Then }+      'type'          { KW_Type }+      'where'         { KW_Where }+      'qualified'     { KW_Qualified }+      'foreign'       { KW_Foreign }+      'forall'        { KW_Forall }+      'exists'        { KW_Exists }+      'kind'          { KW_Kind }+      'family'        { KW_Family }+      'closed'        { KW_Closed }++%monad { P } { thenP } { returnP }+%lexer { lexer } { EOF }+%name parse module+%name parseHsStmt qual+%tokentype { Token }+%%++-- -----------------------------------------------------------------------------+-- Module Header+module :: { HsModule }+      : srcloc modulep                  { $2 { hsModuleSrcLoc = $1, hsModuleOptions = [] } }+      | srcloc PRAGMAOPTIONS module     { $3 { hsModuleSrcLoc = $1, hsModuleOptions = hsModuleOptions $3 ++ $2 } }++modulep  :: { HsModule }+      : 'module' modid maybeexports 'where' body      { HsModule { hsModuleName = $2, hsModuleExports = $3, hsModuleImports = (fst $5), hsModuleDecls = (snd $5)+                                                                 , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } }+      | body                                          { HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (toName Val "main")], hsModuleImports = (fst $1), hsModuleDecls = (snd $1)+                                                                 , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } }++body :: { ([HsImportDecl],[HsDecl]) }+      :  '{' bodyaux '}'                              { $2 }+      |      layout_on  bodyaux close                 { $2 }++bodyaux :: { ([HsImportDecl],[HsDecl]) }+      : optsemis impdecls semis topdecls              { (reverse $2, fixupHsDecls $4) }+      | optsemis                topdecls              { ([], fixupHsDecls $2) }+      | optsemis impdecls optsemis                    { (reverse $2, []) }+      | optsemis                                      { ([], []) }++optsemi :: { () }+      : ';'                                           { () }+      | {- empty -}                                   { () }++semis :: { () }+       : optsemis ';'				{ () }+optsemis :: { () }+       : semis					{ () }+       | {- empty -}				{ () }+-- -----------------------------------------------------------------------------+-- The Export List++maybeexports :: { Maybe [HsExportSpec] }+      :  exports                              { Just $1 }+      |  {- empty -}                          { Nothing }++exports :: { [HsExportSpec] }+      : '(' exportlist maybecomma ')'         { reverse $2 }+      | '(' ')'                               { [] }++maybecomma :: { () }+      : ','                                   { () }+      | {- empty -}                           { () }++exportlist :: { [HsExportSpec] }+      :  exportlist ',' export                { $3 : $1 }+      |  export                               { [$1]  }++export :: { HsExportSpec }+      :  qvar                                 { HsEVar $1 }+      |  qtyconorcls                          { HsEAbs $1 }+      |  qtyconorcls '(' '..' ')'             { HsEThingAll $1 }+      |  qtyconorcls '(' ')'                  { HsEThingWith $1 [] }+      |  qtyconorcls '(' qcnames ')'          { HsEThingWith $1 (reverse $3) }+      |  'module' modid                       { HsEModuleContents $2 }++qcnames :: { [HsName] }+      :  qcnames ',' qcname                   { $3 : $1 }+      |  qcname                               { [$1]  }++qcname :: { HsName }+      :  qvar                                 { $1 }+      |  qcon                                 { $1 }++-- -----------------------------------------------------------------------------+-- Import Declarations++impdecls :: { [HsImportDecl] }+      : impdecls semis impdecl                  { $3 : $1 }+      | impdecl                               { [$1] }++impdecl :: { HsImportDecl }+      : 'import' srcloc optqualified modid maybeas maybeimpspec+                              { HsImportDecl $2 $4 $3 $5 $6 }++optqualified :: { Bool }+      : 'qualified'                           { True  }+      | {- empty -}                           { False }++maybeas :: { Maybe Module }+      : 'as' modid                            { Just $2 }+      | {- empty -}                           { Nothing }++maybeimpspec :: { Maybe (Bool, [HsExportSpec]) }+      : impspec                               { Just $1 }+      | {- empty -}                           { Nothing }++impspec :: { (Bool, [HsExportSpec]) }+      :  '(' importlist maybecomma ')'          { (False, reverse $2) }+      |  '(' ')'                                { (False, []) }+      |  'hiding' '(' importlist maybecomma ')' { (True,  reverse $3) }+      |  'hiding' '(' ')'                       { (True, []) }++importlist :: { [HsExportSpec] }+      :  importlist ',' import                { $3 : $1 }+      |  import                               { [$1]  }++import :: { HsExportSpec }+      :  var                                  { HsEVar $1 }+      |  tyconorcls                           { HsEAbs $1 }+      |  tyconorcls '(' '..' ')'              { HsEThingAll $1 }+      |  tyconorcls '(' ')'                   { HsEThingWith $1 [] }+      |  tyconorcls '(' cnames ')'            { HsEThingWith $1 (reverse $3) }+      |  'class' import                       { HsEQualified ClassName $2 }+      |  'type'  import                       { HsEQualified TypeConstructor $2 }+      |  'kind'  import                       { HsEQualified SortName $2 }++cnames :: { [HsName] }+      :  cnames ',' cname                     { $3 : $1 }+      |  cname                                { [$1]  }++cname :: { HsName }+      :  var                                  { $1 }+      |  con                                  { $1 }++-- -----------------------------------------------------------------------------+-- Fixity Declarations++fixdecl :: { HsDecl }+      : srcloc infix prec ops                 { HsInfixDecl $1 $2 $3 (reverse $4) }++prec :: { Int }+      : {- empty -}                           { 9 }+      | INT                                   {%  checkPrec $1 `thenP` \p ->+                                                  returnP (fromInteger (readInteger p)) }++infix :: { HsAssoc }+      : 'infix'                               { HsAssocNone  }+      | 'infixl'                              { HsAssocLeft  }+      | 'infixr'                              { HsAssocRight }++ops   :: { [HsName] }+      : ops ',' op                            { $3 : $1 }+      | op                                    { [$1] }++-- -----------------------------------------------------------------------------+-- Top-Level Declarations++-- Note: The report allows topdecls to be empty. This would result in another+-- shift/reduce-conflict, so we don't handle this case here, but in bodyaux.++topdecls :: { [HsDecl] }+      : topdecls1 optsemis          { reverse $1 } -- TODO checkRevDecls++topdecls1 :: { [HsDecl] }+      : topdecls1 semis topdecl       { $3 : $1  }+      | topdecl                       { [$1] }++mkind :: { Maybe HsKind }+    : '::' kind                       { Just $2 }+    |                                 { Nothing }++mCTYPE :: { Maybe String }+    :  PRAGMACTYPE STRING PRAGMAEND  { Just $2 }+    |                                { Nothing }++topdecl :: { HsDecl }+      : 'data' mCTYPE ctype srcloc deriving+          {% checkDataHeader $3 `thenP` \(cs,c,t) ->+             returnP hsDataDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $5, hsDeclCTYPE = $2 } }+      | 'data' mCTYPE ctype '::' kind srcloc deriving+          {% checkDataHeader $3 `thenP` \(cs,c,t) ->+             returnP hsDataDecl { hsDeclSrcLoc = $6, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclHasKind = Just $5, hsDeclCTYPE = $2 } }+      | 'data' 'family' simpletype srcloc mkind+                      { HsTypeFamilyDecl $4 True (fst $3) (snd $3) $5 }+      | 'type' 'family' simpletype srcloc mkind+                      { HsTypeFamilyDecl $4 False (fst $3) (snd $3) $5 }+      | 'data' 'kind' ctype srcloc '=' constrs deriving+                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->+                         returnP hsDataDecl { hsDeclDeclType = DeclTypeKind, hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6 } }+      | 'data' mCTYPE ctype srcloc '=' constrs deriving+                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->+                         returnP hsDataDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6, hsDeclCTYPE = $2 } }+      | 'newtype' mCTYPE ctype srcloc '=' constr deriving+                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->+                         returnP hsNewTypeDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclCons = [$6], hsDeclDerives = $7, hsDeclCTYPE = $2} }+      | 'class' srcloc classhead optfundep optcbody+                      { HsClassDecl $2 $3 $5 }+      | 'class' 'alias' srcloc conid varids '=' carhs optcbody+                      {% let+                         { (cxt, clss) = $7;+                           ret = HsClassAliasDecl { hsDeclSrcLoc = $3, hsDeclName = $4, hsDeclTypeArgs = map HsTyVar $5, hsDeclContext = cxt, hsDeclClasses = clss, hsDeclDecls =$8 }+                         } in trace ("\n"++show ret++"\n") (return ret)+                      }+      | 'instance' srcloc classhead optvaldefs+                      { HsInstDecl $2 $3 $4 }+      | 'deriving' 'instance' srcloc classhead+                      { HsDeclDeriving $3 $4 }+      | 'default' srcloc type+                      { HsDefaultDecl $2 $3 }+      | pinfixexp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->+                                         returnP (HsActionDecl $2 p $4) }+      | 'foreign' srcloc 'import' varids mstring '::' ctype+                      {% doForeign $2 (toName Val "import":reverse $4) $5 $7  }+      | 'foreign' srcloc varids mstring '::' ctype+                      {% doForeign $2 (reverse $3) $4 $6  }+      | 'foreign' srcloc varids mstring '::' ctype '=' exp+                      {% doForeignEq $2 (reverse $3) $4 $6 $8 }+      | PRAGMARULES rules PRAGMAEND+              { HsPragmaRules $ map (\x -> x { hsRuleIsMeta = $1 }) (reverse $2) }+      | srcloc PRAGMASPECIALIZE var '::' type PRAGMAEND+                      { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $3, hsDeclType = $5+                                           , hsDeclUniq = error "hsDeclUniq not set"  } }+      | srcloc PRAGMASPECIALIZE conid var '::' type PRAGMAEND+                      { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $4, hsDeclType = $6+                                           , hsDeclUniq = error "hsDeclUniq not set"  } }+      | decl          { $1 }++rule :: { HsRule }+      : srcloc STRING mfreevars exp '=' exp+         { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6+                  , hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" } }++rules :: { [HsRule] }+      : rules ';'rule         { $3 : $1 }+      | rules ';'             { $1 }+      | rule                  { [$1] }+      | {- empty -}           { [] }++mfreevars :: { [(HsName,Maybe HsType)] }+      : 'forall' vbinds '.' { $2 }+      | { [] }++vbinds :: { [(HsName,Maybe HsType)] }+      : vbinds '(' var '::' type ')' { ($3,Just $5) : $1 }+      | vbinds var                   { ($2,Nothing) : $1 }+      |                              { [] }++decls :: { [HsDecl] }+      : optsemis decls1 optsemis      { fixupHsDecls ( reverse $2 ) }+      | optsemis                      { [] }++decls1 :: { [HsDecl] }+      : decls1 semis decl             { $3 : $1 }+      | decl                          { [$1] }++decl :: { HsDecl }+      : signdecl                      { $1 }+      | fixdecl                       { $1 }+      | valdef                        { $1 }+      | pragmaprops                   { $1 }++decllist :: { [HsDecl] }+      : '{' decls '}'                 { $2 }+      |     layout_on  decls close    { $2 }++signdecl :: { HsDecl }+      : vars srcloc '::' ctype        { HsTypeSig $2 (reverse $1) $4 }++pragmainline  :: { HsDecl }+      : PRAGMAINLINE srcloc optphasesn vars PRAGMAEND { HsPragmaProps $2 $1 $4 }++optphasesn :: { (Bool, Maybe Int) }+      : '~' optphases                 { (True, $2) }+      | optphases                     { (False, $1) }++optphases :: { Maybe Int }+      : '[' INT ']'                   { (Just (readInteger $2)) }+      |                               { Nothing }++pragmaprops  :: { HsDecl }+      : PRAGMASTART srcloc  vars PRAGMAEND  { HsPragmaProps $2 $1 $3 }++--pragmaexp  :: { Located HsPragmaExp }+--      : PRAGMAEXP srcloc texps srcloc PRAGMAEND+--        { located ($2,$4) $ HsPragmaExp $1 $3 }++-- ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+-- instead of qvar, we get another shift/reduce-conflict. Consider the+-- following programs:++--    { (+) :: ... }          only var+--    { (+) x y  = ... }      could (incorrectly) be qvar++-- We re-use expressions for patterns, so a qvar would be allowed in patterns+-- instead of a var only (which would be correct). But deciding what the + is,+-- would require more lookahead. So let's check for ourselves...++vars  :: { [HsName] }+      : vars ',' var                  { $3 : $1 }+      | qvar                          {% checkUnQual $1 `thenP` \n ->+                                         returnP [n] }++-- FFI parts+mstring :: { Maybe (String,HsName) }+mstring : STRING var        { Just ($1,$2) }+        | {- empty -}    { Nothing }++-- -----------------------------------------------------------------------------+-- Types++type :: { HsType }+      : btype '->' type               { HsTyFun $1 $3 }+      | btype                         { $1 }+      | 'forall' tbinds '.' ctype     { HsTyForall { hsTypeVars = reverse $2, hsTypeType = $4 } }+      | 'exists' tbinds '.' ctype     { HsTyExists { hsTypeVars = reverse $2, hsTypeType = $4 } }++tbinds :: { [HsTyVarBind] }+      : tbinds tbind                  { $2 : $1 }+      | tbind                         { [$1] }++tbind :: { HsTyVarBind }+       : srcloc varid                   { hsTyVarBind { hsTyVarBindSrcLoc = $1, hsTyVarBindName = $2 } }+       | srcloc '(' varid '::' kind ')' { hsTyVarBind { hsTyVarBindSrcLoc = $1, hsTyVarBindName = $3, hsTyVarBindKind = Just $5 } }++kind :: { HsKind }+      : bkind                          { $1 }+      | bkind '->' kind                { HsKindFn $1 $3 }++bkind :: { HsKind }+       : '(' kind ')'           { $2 }+       |  '*'                   { hsKindStar }+       |  '#'                   { hsKindHash }+       |  '!'                   { hsKindBang }+       |  'bang!'               { hsKindBang }+       |  '*!'                  { hsKindStarBang }+       |  '?'                   { hsKindQuest }+       |  '??'                  { hsKindQuestQuest }+       |  qconid                { HsKind $1 }++btype :: { HsType }+      : btype atype                   { HsTyApp $1 $2 }+      | atype                         { $1 }++atype :: { HsType }+      : gtycon                        { HsTyCon $1 }+      | tyvar                         { HsTyVar $1 }+      | '(' types ')'                 { HsTyTuple (reverse $2) }+      | '(#' '#)'                     { HsTyUnboxedTuple [] }+      | '(#' type '#)'                { HsTyUnboxedTuple [$2] }+      | '(#' types '#)'               { HsTyUnboxedTuple (reverse $2) }+      | '[' type ']'                  { HsTyApp list_tycon $2 }+      | '(' ktype ')'                 { $2 }+      | '(' type '=' type ')'         { HsTyEq $2 $4 }++ktype :: { HsType }+    : srcloc atype '::' kind srcloc { HsTyExpKind { hsTyLType = located ($1,$5) $2, hsTyKind = $4 } }+    | type                          { $1 }++gtycon :: { HsName }+      : qcon                          { $1 }+      | '(' ')'                       { unit_tycon_name }+      | '(' '->' ')'                  { fun_tycon_name }+      | '[' ']'                       { list_tycon_name }+      | '(' commas ')'                { tuple_tycon_name $2 }++-- (Slightly edited) Comment from GHC's hsparser.y:+-- "context => type" vs  "type" is a problem, because you can't distinguish between++--      foo :: (Baz a, Baz a)+--      bar :: (Baz a, Baz a) => [a] -> [a] -> [a]++-- with one token of lookahead.  The HACK is to parse the context as a btype+-- (more specifically as a tuple type), then check that it has the right form+-- C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!++ctype :: { HsQualType }+      : context '=>' type             { HsQualType $1 $3 }+      | type                          { HsQualType [] $1 }++context :: { HsContext }+        : btype				{% checkContext $1 }++carhs :: { (HsContext, HsContext) }+       : btype '=>' btype {% liftM2 (,)     (checkContext $1) (checkContext $3) }+       | btype            {% liftM ((,) []) (checkContext $1) }++classhead :: { HsClassHead }+    : ctype {% qualTypeToClassHead $1 }++types :: { [HsType] }+      : types ',' type                { $3 : $1 }+      | type  ',' type                { [$3, $1] }++simpletype :: { (HsName, [HsType]) }+      : tycon atypes                  { ($1,reverse $2) }++atypes :: { [HsType] }+      : atypes atype                  { $2 : $1 }+      | {- empty -}                   { [] }++-- -----------------------------------------------------------------------------+-- Datatype declarations++constrs :: { [HsConDecl] }+      : constrs '|' constr            { $3 : $1 }+      | constr                        { [$1] }++constr :: { HsConDecl }+      : srcloc mexists scontype               { HsConDecl { hsConDeclSrcLoc = $1, hsConDeclName = (fst $3), hsConDeclConArg = (snd $3), hsConDeclExists = $2 } }+      | srcloc mexists sbtype conop sbtype    { HsConDecl { hsConDeclSrcLoc = $1, hsConDeclName = $4, hsConDeclConArg = [$3,$5], hsConDeclExists = $2 } }+      | srcloc mexists con '{' fielddecls '}'+                                      { HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = (reverse $5), hsConDeclExists = $2 } }+      | srcloc mexists con '{' '}'+                                      { HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = [], hsConDeclExists = $2 } }++mexists :: { [HsTyVarBind] }+        : 'exists' tbinds '.'         { $2 }+        | 'forall' tbinds '.'         { $2 }  -- Allowed for GHC compatability+        |                             { [] }++scontype :: { (HsName, [HsBangType]) }+      : btype                         {% splitTyConApp $1 `thenP` \(c,ts) ->+                                         returnP (c,map HsUnBangedTy ts) }+      | scontype1                     { $1 }++scontype1 :: { (HsName, [HsBangType]) }+      : btype '!' atype               {% splitTyConApp $1 `thenP` \(c,ts) ->+                                         returnP (c,map HsUnBangedTy ts+++                                                      [HsBangedTy $3]) }+      | btype 'bang!' atype               {% splitTyConApp $1 `thenP` \(c,ts) ->+                                         returnP (c,map HsUnBangedTy ts+++                                                      [HsBangedTy $3]) }+      | scontype1 satype              { (fst $1, snd $1 ++ [$2] ) }++satype :: { HsBangType }+      : atype                         { HsUnBangedTy $1 }+      | '!' atype                     { HsBangedTy   $2 }+      | 'bang!' atype                 { HsBangedTy   $2 }++sbtype :: { HsBangType }+      : btype                         { HsUnBangedTy $1 }+      | '!' atype                     { HsBangedTy   $2 }+      | 'bang!' atype                 { HsBangedTy   $2 }++fielddecls :: { [([HsName],HsBangType)] }+      : fielddecls ',' fielddecl      { $3 : $1 }+      | fielddecl                     { [$1] }++fielddecl :: { ([HsName],HsBangType) }+      : vars '::' stype               { (reverse $1, $3) }++stype :: { HsBangType }+      : type                          { HsUnBangedTy $1 }+      | '!' atype                     { HsBangedTy   $2 }+      | 'bang!' atype                 { HsBangedTy   $2 }++deriving :: { [HsName] }+      : {- empty -}                   { [] }+      | 'deriving' qtycls             { [$2] }+      | 'deriving' '('          ')'   { [] }+      | 'deriving' '(' dclasses ')'   { reverse $3 }++dclasses :: { [HsName] }+      : dclasses ',' qtycls           { $3 : $1 }+      | qtycls                        { [$1] }++-- -----------------------------------------------------------------------------+-- Class declarations++optcbody :: { [HsDecl] }+      : 'where' decllist                      { fixupHsDecls $2 }+      | {- empty -}                           { [] }++cdefaults :: { [HsDecl] }+     : cdefaults ';' valdef                  { $3 : $1 }+     | valdef                                { [$1] }++-- -----------------------------------------------------------------------------+-- Functional dependencies++optfundep :: { [([HsName],[HsName])] }+      : {- empty -}                           { [] }+      | '|' fundeps                           { reverse $2 }++fundeps   :: { [([HsName],[HsName])] }+      : fundeps ',' fundep                    { ($3:$1) }+      | fundep                                { [$1]    }++fundep    :: { ([HsName],[HsName]) }+      : varids '->' varids                    { ($1,$3) }++varids    :: { [HsName] }+      : {- empty -}                           { [] }+      | varids varid                          { ($2:$1) }++-- -----------------------------------------------------------------------------+-- Instance declarations++optvaldefs :: { [HsDecl] }+      : 'where' '{' valdefs '}'               { $3 }+      | 'where' layout_on valdefs close       { $3 }+      | {- empty -}                           { [] }++-- Recycling...++valdefs :: { [HsDecl] }+      : cdefaults optsemi                     { fixupHsDecls (reverse $1) }+      | optsemi                               { [] }++-- -----------------------------------------------------------------------------+-- Value definitions++valdef :: { HsDecl }+      : 'type' simpletype srcloc '=' type+                      { HsTypeDecl $3 (fst $2) (snd $2) $5 }+--      | 'data' simpletype srcloc+--                      { HsTypeFamilyDecl $3 True (fst $2) (snd $2) Nothing }+--      | 'data' simpletype srcloc '::' kind+--                      { HsTypeFamilyDecl $3 True (fst $2) (snd $2) (Just $5) }+      | 'type' simpletype srcloc+                      { HsTypeFamilyDecl $3 False (fst $2) (snd $2) Nothing }+      | 'type' simpletype srcloc '::' kind+                      { HsTypeFamilyDecl $3 False (fst $2) (snd $2) (Just $5) }+      | pinfixexp srcloc rhs optwhere          {% checkValDef $2 $1 $3 $4}+      | srcloc PRAGMASPECIALIZE 'instance'  type PRAGMAEND+                      { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = nameName u_instance , hsDeclType = $4+                                           , hsDeclUniq = error "hsDeclUniq not set"  } }+      | pragmainline { $1 }++optwhere :: { [HsDecl] }+       : 'where' decllist		{ $2 }+       | {- empty -}			{ [] }++rhs   :: { HsRhs }+      : '=' exp                       {% checkExpr $2 `thenP` \e ->+                                         returnP (HsUnGuardedRhs e) }+      | gdrhs                         { HsGuardedRhss  (reverse $1) }++gdrhs :: { [HsGuardedRhs] }+      : gdrhs gdrh                    { $2 : $1 }+      | gdrh                          { [$1] }++gdrh :: { HsGuardedRhs }+      : '|' exp srcloc '=' exp        {% checkExpr $2 `thenP` \g ->+                                         checkExpr $5 `thenP` \e ->+                                         returnP (HsGuardedRhs $3 g e) }++-- -----------------------------------------------------------------------------+-- Expressions++exp   :: { HsExp }+      : infixexp '::' srcloc ctype    { HsExpTypeSig $3 $1 $4 }+      | infixexp                      { $1 }++infixexp :: { HsExp }+      : exp10                         { $1 }+      | infixexp qop exp10            { HsInfixApp $1 $2 $3 }++exp10 :: { HsExp }+      : '\\' aexps srcloc '->' exp    {% checkPatterns (reverse $2) `thenP` \ps ->+                                         returnP (HsLambda $3 ps $5) }+      | 'let' decllist 'in' exp       { HsLet $2 $4 }+-- -- > | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }+      | 'if' exp optsemi 'then' exp optsemi 'else' exp { HsIf $2 $5 $8 }+      | 'case' exp 'of' altslist      { HsCase $2 $4 }+      | '-' fexp                      { HsNegApp $2 }+      | 'do' stmtlist                 { HsDo $2 }+      | fexp                          { $1 }++fexp :: { HsExp }+      : fexp aexp                     { HsApp $1 $2 }+      | aexp                          { $1 }++aexps :: { [HsExp] }+      : aexps aexp                    { $2 : $1 }+      | aexp                          { [$1] }++-- UGLY: Because patterns and expressions are mixed, aexp has to be split into+-- two rules: One left-recursive and one right-recursive. Otherwise we get two+-- reduce/reduce-errors (for as-patterns and irrefutable patters).++-- Note: The first alternative of aexp is not neccessarily a record update, it+-- could be a labeled construction, too.++aexp  :: { HsExp }+      : aexp '{' fbinds '}'           {% mkRecConstrOrUpdate $1 (reverse $3) }+      | aexp1                         { $1 }++-- Even though the variable in an as-pattern cannot be qualified, we use+-- qvar here to avoid a shift/reduce conflict, and then check it ourselves+-- (as for vars above).++aexp1 :: { HsExp }+      : qvar                          { HsVar $1 }+      | gcon                          { $1 }+      | literal                       { $1 }+      | '(' exp ')'                   { HsParen $2 }+      | '(' texps ')'                 { HsTuple (reverse $2) }+      | '(#' '#)'                     { HsUnboxedTuple [] }+      | '(#' exp '#)'                 { HsUnboxedTuple [$2] }+      | '(#' texps '#)'               { HsUnboxedTuple (reverse $2) }+      | '[' list ']'                  { $2 }+      | '(' infixexp qop ')'          { HsLeftSection $3 $2  }+      | '(' qopm infixexp ')'         { HsRightSection $3 $2 }+      | qvar '@' aexp                 {% checkUnQual $1 `thenP` \n ->+                                         returnP (HsAsPat n $3) }+      | srcloc '_'                    { HsWildCard $1 }+      | '~' srcloc aexp1 srcloc       { HsIrrPat $ located ($2,$4) $3 }+      | 'bang!' srcloc aexp1 srcloc   { HsBangPat $ located ($2,$4) $3 }++commas :: { Int }+      : commas ','                    { $1 + 1 }+      | ','                           { 1 }++texps :: { [HsExp] }+      : texps ',' exp                 { $3 : $1 }+      | exp ',' exp                   { [$3,$1] }++-- -----------------------------------------------------------------------------+-- List expressions++-- The rules below are little bit contorted to keep lexps left-recursive while+-- avoiding another shift/reduce-conflict.++list :: { HsExp }+      : exp                           { HsList [$1] }+      | lexps                         { HsList (reverse $1) }+      | exp '..'                      { HsEnumFrom $1 }+      | exp ',' exp '..'              { HsEnumFromThen $1 $3 }+      | exp '..' exp                  { HsEnumFromTo $1 $3 }+      | exp ',' exp '..' exp          { HsEnumFromThenTo $1 $3 $5 }+      | exp '|' quals                 { HsListComp $1 (reverse $3) }++lexps :: { [HsExp] }+      : lexps ',' exp                 { $3 : $1 }+      | exp ',' exp                   { [$3,$1] }++-- -----------------------------------------------------------------------------+-- Expressions++pexp   :: { HsExp }+      : pinfixexp '::' srcloc ctype    { HsExpTypeSig $3 $1 $4 }+      | pinfixexp                      { $1 }++pinfixexp :: { HsExp }+      : pexp10                         { $1 }+      | pinfixexp qop pexp10            { HsInfixApp $1 $2 $3 }++pexp10 :: { HsExp }+      : '-' pfexp                      { HsNegApp $2 }+      | pfexp                          { $1 }++pfexp :: { HsExp }+      : pfexp paexp                     { HsApp $1 $2 }+      | paexp                          { $1 }++-- UGLY: Because patterns and expressions are mixed, aexp has to be split into+-- two rules: One left-recursive and one right-recursive. Otherwise we get two+-- reduce/reduce-errors (for as-patterns and irrefutable patters).++-- Note: The first alternative of aexp is not neccessarily a record update, it+-- could be a labeled construction, too.++paexp  :: { HsExp }+      : paexp '{' pfbinds '}'           {% mkRecConstrOrUpdate $1 (reverse $3) }+      | paexp '{'  '}'                  {% mkRecConstrOrUpdate $1 [] }+      | paexp1                         { $1 }++-- Even though the variable in an as-pattern cannot be qualified, we use+-- qvar here to avoid a shift/reduce conflict, and then check it ourselves+-- (as for vars above).++paexp1 :: { HsExp }+      : qvar                          { HsVar $1 }+      | gcon                          { $1 }+      | literal                       { $1 }+      | '(' pexp ')'                  { HsParen $2 }+      | '(' ptexps ')'                { HsTuple (reverse $2) }+      | '(#' '#)'                     { HsUnboxedTuple [] }+      | '(#' pexp '#)'                { HsUnboxedTuple [$2] }+      | '(#' ptexps '#)'              { HsUnboxedTuple (reverse $2) }+      | '[' plist ']'                 { $2 }+      | '(' pinfixexp qop ')'          { HsLeftSection $3 $2  }+      | '(' qopm pinfixexp ')'         { HsRightSection $3 $2 }+      | qvar '@' paexp                {% checkUnQual $1 `thenP` \n ->+                                         returnP (HsAsPat n $3) }+      | srcloc '_'                    { HsWildCard $1 }+      | '~' srcloc paexp1 srcloc      { HsIrrPat $ located ($2,$4) $3 }+      | 'bang!' srcloc paexp1 srcloc  { HsBangPat $ located ($2,$4) $3 }++ptexps :: { [HsExp] }+      : ptexps ',' pexp                 { $3 : $1 }+      | pexp ',' pexp                   { [$3,$1] }++-- -----------------------------------------------------------------------------+-- List expressions++-- The rules below are little bit contorted to keep lexps left-recursive while+-- avoiding another shift/reduce-conflict.++plist :: { HsExp }+      : pexp                           { HsList [$1] }+      | plexps                         { HsList (reverse $1) }++plexps :: { [HsExp] }+      : plexps ',' pexp                 { $3 : $1 }+      | pexp ',' pexp                   { [$3,$1] }+-- -----------------------------------------------------------------------------+-- List comprehensions++quals :: { [HsStmt] }+      : quals ',' qual                        { $3 : $1 }+      | qual                                  { [$1] }++qual  :: { HsStmt }+      : exp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->+                                         returnP (HsGenerator $2 p $4) }+      | exp                           { HsQualifier $1 }+      | 'let' decllist                { HsLetStmt $2 }++-- -----------------------------------------------------------------------------+-- Case alternatives++altslist :: { [HsAlt] }+      : '{' alts optsemi '}'                  { reverse $2 }+      |     layout_on  alts optsemi close     { reverse $2 }++alts :: { [HsAlt] }+      : alts ';' alt                          { $3 : $1 }+      | alt                                   { [$1] }++alt :: { HsAlt }+      : pinfixexp srcloc ralt optwhere {% checkPattern $1 `thenP` \p ->+                                 returnP (HsAlt $2 p $3 $4) }++ralt :: { HsRhs }+      : '->' exp                              { HsUnGuardedRhs $2 }+      | gdpats                                { HsGuardedRhss (reverse $1) }++gdpats :: { [HsGuardedRhs] }+      : gdpats gdpat                          { $2 : $1 }+      | gdpat                                 { [$1] }++gdpat :: { HsGuardedRhs }+      : '|' exp srcloc '->' exp               { HsGuardedRhs $3 $2 $5 }++-- -----------------------------------------------------------------------------+-- Statement sequences++stmtlist :: { [HsStmt] }+        : '{' stmts '}'               { $2 }+        |     layout_on  stmts close  { $2 }++stmts :: { [HsStmt] }+      : stmt stmts1                   { $1:$2 }+      | ';' stmts                     { $2 }+      | {- empty -}                   { [] }++stmts1 :: { [HsStmt] }+      : ';' stmts                     { $2 }+      |                               { [] }++stmt :: { HsStmt }+    : qual            { $1 }++-- -----------------------------------------------------------------------------+-- Record Field Update/Construction++fbinds :: { [HsFieldUpdate] }+      : fbinds ',' fbind              { $3 : $1 }+      | fbind                         { [$1] }++fbind :: { HsFieldUpdate }+      : qvar '=' exp                  { HsFieldUpdate $1 $3 }++pfbinds :: { [HsFieldUpdate] }+      : pfbinds ',' pfbind              { $3 : $1 }+      | pfbind                         { [$1] }++pfbind :: { HsFieldUpdate }+      : qvar '=' pexp                  { HsFieldUpdate $1 $3 }++-- -----------------------------------------------------------------------------+-- Variables, Constructors and Operators.++gcon :: { HsExp }+      : '(' ')'               { unit_con }+      | '[' ']'               { HsList [] }+      | '(' commas ')'        { tuple_con $2 }+      | qcon                  { HsCon $1 }++var   :: { HsName }+      : varid                 { $1 }+      | '(' varsym ')'        { $2 }++qvar  :: { HsName }+      : qvarid                { $1 }+      | '(' qvarsym ')'       { $2 }++con   :: { HsName }+      : conid                 { $1 }+      | '(' consym ')'        { $2 }++qcon  :: { HsName }+      : qconid                { $1 }+      | '(' qconsym ')'       { $2 }++varop :: { HsName }+      : varsym                { $1 }+      | '`' varid '`'         { $2 }++qvarop :: { HsName }+      : qvarsym               { $1 }+      | '`' qvarid '`'        { $2 }++qvaropm :: { HsName }+      : qvarsymm              { $1 }+      | '`' qvarid '`'        { $2 }++conop :: { HsName }+      : consym                { $1 }+      | '`' conid '`'         { $2 }++qconop :: { HsName }+      : qconsym               { $1 }+      | '`' qconid '`'        { $2 }++op    :: { HsName }+      : varop                 { $1 }+      | conop                 { $1 }++qop   :: { HsExp }+      : qvarop                { HsVar $1 }+      | qconop                { HsCon $1 }++qopm  :: { HsExp }+      : qvaropm               { HsVar $1 }+      | qconop                { HsCon $1 }++qvarid :: { HsName }+      : varid                 { $1 }+      | QVARID                { $1 }++varid :: { HsName }+      : VARID                 { $1 }+      | 'as'                  { as_name }+      | 'alias'               { toName UnknownType "alias" }+      | 'kind'                { toName UnknownType "kind" }+      | 'closed'              { toName UnknownType "closed" }+      | 'family'              { toName UnknownType "family" }+      | 'qualified'           { qualified_name }+      | 'hiding'              { hiding_name }+      | 'forall'              { toName UnknownType "forall" }+      | 'exists'              { toName UnknownType "exists" }++qconid :: { HsName }+      : conid                 { $1 }+      | QCONID                { $1 }++conid :: { HsName }+      : CONID                 { $1 }++qconsym :: { HsName }+      : consym                { $1 }+      | QCONSYM               { $1 }++consym :: { HsName }+      : CONSYM                { $1 }++qvarsym :: { HsName }+      : varsym                { $1 }+      | qvarsym1              { $1 }++qvarsymm :: { HsName }+      : varsymm               { $1 }+      | qvarsym1              { $1 }++varsym :: { HsName }+      : VARSYM                { $1 }+      | '-'                   { minus_name }+      | '!'                   { pling_name }+      | 'bang!'               { pling_name }+      | '?'                   { toName UnknownType "?" }+      | '??'                  { toName UnknownType "??" }+      | '*!'                  { toName UnknownType "*!" }+      | '*'                   { star_name }+      | '#'                   { hash_name }+      | '.'                   { dot_name }++varsymm :: { HsName } -- varsym not including '-'+      : VARSYM                { $1 }+      | '!'                   { pling_name }+      | 'bang!'               { pling_name }+      | '*'                   { star_name }+      | '#'                   { hash_name }+      | '.'                   { dot_name }++qvarsym1 :: { HsName }+      : QVARSYM               { $1 }++literal :: { HsExp }+      : INT                   { HsLit (HsInt (readInteger $1)) }+      | UINT                  { HsLit (HsIntPrim (readInteger $1)) }+      | CHAR                  { HsLit (HsChar $1) }+      | UCHAR                 { HsLit (HsCharPrim $1) }+      | RATIONAL              { HsLit (HsFrac (readRational $1)) }+      | STRING                { HsLit (HsString $1) }+      | USTRING               { HsLit (HsStringPrim $1) }++ srcloc :: { SrcLoc } :       {% getSrcLoc }++-- -----------------------------------------------------------------------------+-- Layout++close :: { () }+      : vccurly               { () } -- context popped in lexer.+      | error                 {% popContext }++layout_on  :: { () }  :   {% getSrcLoc `thenP` \sl ->+                                 pushCurrentContext  }++--                                 pushCurrentContext (Layout (srcLocColumn sl)) }++-- -----------------------------------------------------------------------------+-- Miscellaneous (mostly renamings)++modid :: { Module }+      : CONID                 { toModule $ show $1 }+      | QCONID                { toModule $ show $1 } -- (fst $1 ++ "." ++ snd $1) }++tyconorcls :: { HsName }+      : conid                 { $1 }++tycon :: { HsName }+      : conid                 { $1 }++qtyconorcls :: { HsName }+      : qconid                { $1 }++qtycls :: { HsName }+      : qconid                { $1 }++tyvar :: { HsName }+      : varid                 { $1 }++-- -----------------------------------------------------------------------------++{++{-# NOINLINE parse #-}+{-# NOINLINE parseHsStmt #-}+parse       :: P HsModule+parseHsStmt :: P HsStmt++happyError = parseError "Parse error"+--hsSymbol x = HsIdent x+readInteger x = fromIntegral x+readRational x = x++as_name	              = toName UnknownType  "as"+derive_name	      = toName UnknownType  "derive"+qualified_name        = toName UnknownType  "qualified"+hiding_name	      = toName UnknownType  "hiding"+minus_name	      = toName UnknownType  "-"+pling_name	      = toName UnknownType  "!"+star_name	      = toName UnknownType  "*"+hash_name	      = toName UnknownType  "#"+dot_name	      = toName UnknownType  "."+prelude_mod	      = toModule "Prelude"+main_mod	      = toModule "Main"++tuple_con_name i      = toName DataConstructor (toModule "Jhc.Prim.Prim","("++replicate i ','++")")++unit_con	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = dc_Unit }+tuple_con i	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = (tuple_con_name i) }++unit_tycon_name       = tc_Unit+fun_tycon_name        = tc_Arrow+list_tycon_name       = toName UnknownType "[]"+tuple_tycon_name i    = tuple_con_name i++list_tycon	      = HsTyCon list_tycon_name++toUnqualName n = toName UnknownType (Nothing :: Maybe Module,n)+}
+ src/FrontEnd/HsPretty.hs view
@@ -0,0 +1,707 @@+-----------------------------------------------------------------------------+--  $Id: HsPretty.hs,v 1.10 2001/12/17 03:38:54 bjpop Exp $+--+-- (c) The GHC Team, Noel Winstanley 1997-2000+--+-- Pretty printer for Haskell.+--+-----------------------------------------------------------------------------++module FrontEnd.HsPretty (PPLayout(..),PPHsMode(..),+		render,+		ppHsModule,+		ppHsDecl,+		ppHsDecls,+		ppHsExp,+                ppHsStmt,+                ppHsPat,+                ppHsAlt,+                ppGAlt,+                ppHsGuardedRhs+		) where++import Data.Char+import qualified Text.PrettyPrint.HughesPJ as P++import Doc.DocLike(TextLike(..),DocLike(..))+import Doc.PPrint(pprint)+import FlagDump as FD+import FrontEnd.HsSyn+import FrontEnd.Rename(unRename)+import FrontEnd.SrcLoc(Located(..))+import Name.Name+import Name.Names+import Options+import qualified Doc.DocLike as DL+import qualified Doc.PPrint as P++infixl 5 $$$++-----------------------------------------------------------------------------+-- pretty printing monad++data PPLayout = PPOffsideRule		-- classical layout+	      | PPSemiColon		-- classical layout made explicit+	      | PPInLine		-- inline decls, \n between them+	      | PPNoLayout		-- everything on a single line+	      deriving Eq++type Indent = Int++data PPHsMode = PPHsMode {+			 classIndent,  -- class, instance+			 doIndent,+			 caseIndent,+			 letIndent,+			 whereIndent :: Indent,+			 onsideIndent :: Indent,+			 spacing :: Bool, -- blank lines between statements?+			 layout :: PPLayout,   -- to do+			 comments :: Bool -- to come later+			 }++defaultMode = PPHsMode{+		      classIndent = 8,+		      doIndent = 3,+		      caseIndent = 4,+		      letIndent = 4,+		      whereIndent = 6,+		      onsideIndent = 2,+		      spacing = True,+		      layout = PPOffsideRule,+		      comments = True+		      }++newtype DocM s a = DocM (s -> a)++instance Functor (DocM s) where+	 fmap f xs = do x <- xs; return (f x)++instance Monad (DocM s) where+	(>>=) = thenDocM+	(>>) = then_DocM+	return = retDocM++{-# INLINE thenDocM #-}+{-# INLINE then_DocM #-}+{-# INLINE retDocM #-}+{-# INLINE unDocM #-}+{-# INLINE getPPEnv #-}+thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)+then_DocM m k = DocM $ (\s ->case unDocM m $ s of a ->  unDocM k $ s)+retDocM a = DocM (\s -> a)+unDocM :: DocM s a -> (s -> a)+unDocM (DocM f) = f++-- all this extra stuff, just for this one function..+getPPEnv :: DocM s s+getPPEnv = DocM id++-- So that pp code still looks the same+-- this means we lose some generality though+type Doc = DocM PPHsMode P.Doc++-- The pretty printing combinators++nest :: Int -> Doc -> Doc+nest i m = m >>= return . P.nest i++dropAs (HsAsPat _ e) = e+dropAs e = e++-- Literals+instance DL.TextLike Doc where+    empty = return P.empty+    text = return . P.text+    char = return . P.char++int :: Int -> Doc+int = return . P.int++integer :: Integer -> Doc+integer = return . P.integer++float :: Float -> Doc+float = return . P.float++double :: Double -> Doc+double = return . P.double++-- Simple Combining Forms++parens, brackets, braces :: Doc -> Doc+parens d = d >>= return . P.parens+parenszh d = d >>= \d' -> return $ P.text "(# " P.<> d' P.<> P.text " #)"++brackets d = d >>= return . P.brackets+braces d = d >>= return . P.braces++-- Constants++semi,comma,equals :: Doc+semi = return P.semi+comma = return P.comma+equals = return P.equals++-- Combinators+--+instance DocLike Doc where+    aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}+    aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}+    aM <$> bM = do{a<-aM;b<-bM;return (a P.$$ b)}+    hcat dl = sequence dl >>= return . P.hcat+    hsep dl = sequence dl >>= return . P.hsep+    vcat dl = sequence dl >>= return . P.vcat++($$) :: Doc -> Doc -> Doc+aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}++fsep :: [Doc] -> Doc+fsep dl = sequence dl >>= return . P.fsep++-- Yuk, had to cut-n-paste this one from Pretty.hs+punctuate :: Doc -> [Doc] -> [Doc]+punctuate p []     = []+punctuate p (d:ds) = go d ds+                   where+                     go d [] = [d]+                     go d (e:es) = (d <> p) : go e es++-- this is the equivalent of runM now.+renderWithMode :: PPHsMode -> Doc -> String+renderWithMode ppMode d = P.render . unDocM d $ ppMode++render :: Doc -> String+render = renderWithMode defaultMode++-------------------------  Pretty-Print a Module --------------------+ppHsModule :: HsModule -> Doc+ppHsModule (HsModule mod _ mbExports imp decls _ _) =+   topLevel (ppHsModuleHeader mod mbExports)+            (map ppHsImportDecl imp ++ map ppHsDecl decls)++ppHsDecls :: [HsDecl] -> Doc+ppHsDecls ds = vcat $ map ppHsDecl ds++--------------------------  Module Header ------------------------------+ppHsModuleHeader :: Module -> Maybe [HsExportSpec] ->  Doc+ppHsModuleHeader (Module modName) mbExportList = mySep [+		 text "module",+		 text $ show modName,+		 maybePP (parenList . map ppHsExportSpec) mbExportList,+		 text "where"]++ppHsExportSpec :: HsExportSpec -> Doc+ppHsExportSpec e = f e where+    f (HsEVar name)                     = ppHsQNameParen name+    f (HsEAbs name)                     = ppHsQName name+    f (HsEThingAll name)                = ppHsQName name <> text"(..)"+    f (HsEThingWith name nameList)      = ppHsQName name <> (parenList . map ppHsQNameParen $ nameList)+    f (HsEModuleContents (show -> name)) = text "module" <+> text name+    f (HsEQualified ClassName e)         = text "class" <+> ppHsExportSpec e+    f (HsEQualified SortName e)          = text "kind" <+> ppHsExportSpec e+    f (HsEQualified TypeConstructor e)   = text "type" <+> ppHsExportSpec e+    f (HsEQualified DataConstructor e)   = text "data" <+> ppHsExportSpec e+    f (HsEQualified n e)                 = tshow n <+> ppHsExportSpec e++tshow = text . show+ppHsImportDecl (HsImportDecl pos (show -> mod) bool mbName mbSpecs) =+	   mySep [text "import",+		 if bool then text "qualified" else empty,+		 text mod,+		 maybePP (\(show -> n) -> text "as" <+> text n) mbName,+		 maybePP exports mbSpecs]+           where+	   exports (b,specList)+	    | b = text "hiding" <+> (parenList . map ppHsExportSpec $ specList)+	    | otherwise = parenList . map ppHsExportSpec $  specList++ppHsTName (n,Nothing) = ppHsName n+ppHsTName (n,Just t) = parens (ppHsName n <+> text "::" <+> ppHsType t)++-------------------------  Declarations ------------------------------+ppHsRule prules@HsRule {} = text (show (hsRuleString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest  where+    vars = hsep (map ppHsTName $ hsRuleFreeVars prules)+    rest = ppHsExp (hsRuleLeftExpr prules) <+> text "=" <+> ppHsExp (hsRuleRightExpr prules)++ppClassHead :: HsClassHead -> Doc+ppClassHead (HsClassHead c n ts) = ans c where+    ans [] = f n ts+    ans c = ppHsContext c <+> text "=>" <+> f n ts+    f n ts = ppHsType (foldl HsTyApp (HsTyCon n)  ts)++ppHsDecl :: HsDecl -> Doc+ppHsDecl (HsActionDecl _ p e) = ppHsPat p <+> text "<-" <+> ppHsExp e+ppHsDecl (HsDeclDeriving _ e) = text "derive instance" <+> ppClassHead e+ppHsDecl (HsPragmaRules rs@(HsRule { hsRuleIsMeta = False }:_)) = text "{-# RULES" $$ nest 4 (myVcat (map ppHsRule rs)) $$ text "#-}"+ppHsDecl (HsPragmaRules rs@(HsRule { hsRuleIsMeta = True }:_)) = text "{-# METARULES" $$ nest 4 (myVcat (map ppHsRule rs)) $$ text "#-}"+--ppHsDecl prules@HsPragmaRules {} = text ("{-# RULES " ++ show (hsDeclString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest $$ text "#-}" where+--    vars = hsep (map ppHsTName $ hsDeclFreeVars prules)+--    rest = ppHsExp (hsDeclLeftExpr prules) <+> text "=" <+> ppHsExp (hsDeclRightExpr prules)+ppHsDecl prules@HsPragmaSpecialize {} = text "{-# SPECIALIZE ... #-}" --  ++ show (hsDeclString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest $$ text "#-}" where+--    vars = hsep (map ppHsTName $ hsDeclFreeVars prules)+--    rest = ppHsExp (hsDeclLeftExpr prules) <+> text "=" <+> ppHsExp (hsDeclRightExpr prules)+ppHsDecl fd@(HsForeignDecl _ _ n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)+ppHsDecl fd@(HsForeignExport _ _ n qt) = text "ForeignExport" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)+ppHsDecl (HsTypeDecl loc name nameList htype) =+	   --blankline $+	   mySep ( [text "type",ppHsName name]+		   ++ map ppHsType nameList+		   ++ [equals, ppHsType htype])++ppHsDecl HsDataDecl { .. } = ans where+    ans = mySep ([declType, ppHsContext hsDeclContext, ppHsName hsDeclName]+                  ++ map ppHsName hsDeclArgs)+                  <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+                                           (map ppHsConstr hsDeclCons))+                       $$$ ppHsDeriving hsDeclDerives)+    declType = case hsDeclDeclType of+        DeclTypeKind    -> text "data kind"+        DeclTypeData    -> text "data"+        DeclTypeNewtype -> text "newtype"++-- special case for empty class declaration+ppHsDecl (HsClassDecl pos qualType []) =+	   --blankline $+	   mySep [text "class", ppClassHead qualType]+ppHsDecl (HsClassDecl pos qualType declList) =+	   --blankline $+	   mySep [text "class", ppClassHead qualType, text "where"]+	   $$$ body classIndent (map ppHsDecl declList)++ppHsDecl (HsClassAliasDecl pos name args context classes declList) =+	   --blankline $+	   mySep ([text "class alias", ppHsName name] ++ map ppHsType args+                  ++ [equals, ppHsContext context, text "=>", ppHsContext classes, text "where"])+	   $$$ body classIndent (map ppHsDecl declList)++-- m{spacing=False}+-- special case for empty instance declaration+ppHsDecl (HsInstDecl pos qualType []) =+	   --blankline $+	   mySep [text "instance", ppClassHead qualType]+ppHsDecl (HsInstDecl pos qualType declList) =+	   --blankline $+	   mySep [text "instance", ppClassHead qualType, text "where"]+	   $$$ body classIndent (map ppHsDecl declList)++ppHsDecl (HsDefaultDecl pos htype) =+	   --blankline $+	   text "default" <+> ppHsType htype++ppHsDecl (HsTypeSig pos nameList qualType) =+	 --blankline $+	 mySep ((punctuate comma . map ppHsNameParen $ nameList)+	       ++ [text "::", ppHsQualType qualType])++{-+ppHsDecl (HsFunBind pos matches)+   = foldr ($$$) empty (map ppMatch matches)+-}+ppHsDecl (HsFunBind matches)+   =  foldr ($$$) empty (map ppMatch matches)++ppHsDecl (HsPatBind pos pat rhs whereDecls)+   = myFsep [ppHsPatOrOp pat, ppHsRhs rhs] $$$ ppWhere whereDecls+    where+	-- special case for single operators+	ppHsPatOrOp (HsPVar n) = ppHsNameParen n+	ppHsPatOrOp p = ppHsPat p++ppHsDecl (HsInfixDecl pos assoc prec nameList) =+	   --blankline $+	   mySep ([ppAssoc assoc, int prec]+	     ++ (punctuate comma . map ppHsNameInfix $ nameList))+	    where+	    ppAssoc HsAssocNone  = text "infix"+	    ppAssoc HsAssocLeft  = text "infixl"+	    ppAssoc HsAssocRight = text "infixr"+ppHsDecl (HsPragmaProps _ w ns) = text "{-# " <> text w <+> mySep (punctuate comma . map ppHsNameParen $ ns) <+> text "#-}"+ppHsDecl _ = error "ppHsDecl: unknown construct"++ppMatch (HsMatch pos f ps rhs whereDecls)+   =   myFsep (ppHsQNameParen f : map ppHsPat ps ++ [ppHsRhs rhs])+   $$$ ppWhere whereDecls++ppWhere [] = empty+ppWhere l = nest 2 (text "where" $$$ body whereIndent (map ppHsDecl l))++------------------------- Data & Newtype Bodies -------------------------+mprintExists :: HsConDecl -> Doc+mprintExists hcd = case hsConDeclExists hcd of+    [] -> empty+    vs -> text "exists" <+> hsep (map (return . pprint) vs) <+> char '.'++ppHsConstr :: HsConDecl -> Doc+ppHsConstr cd@HsRecDecl { hsConDeclName = name, hsConDeclRecArg = fieldList } =+	 mprintExists cd <+> ppHsName name+	 <> (braceList . map ppField $ fieldList)+ppHsConstr cd@HsConDecl { hsConDeclName = name, hsConDeclConArg = typeList}+     | isSymbolName name && length typeList == 2 =+	 let [l, r] = typeList in+	 mprintExists cd <+> myFsep [ppHsBangType l, ppHsName name, ppHsBangType r]+     | otherwise = mprintExists cd <+> (mySep $ (ppHsName name) :+		 map ppHsBangType typeList)++ppField :: ([HsName],HsBangType) -> Doc+ppField (names, ty) = myFsepSimple $  (punctuate comma . map ppHsName $ names) +++			      [text "::", ppHsBangType ty]++ppHsBangType :: HsBangType -> Doc+ppHsBangType (HsBangedTy ty) = char '!' <> ppHsTypeArg ty+ppHsBangType (HsUnBangedTy ty) = ppHsTypeArg ty++ppHsDeriving :: [HsName] -> Doc+ppHsDeriving []  = empty+ppHsDeriving [d] = text "deriving" <+> ppHsQName d+ppHsDeriving ds  = text "deriving" <+> parenList (map ppHsQName ds)++------------------------- Types -------------------------+ppHsQualType :: HsQualType -> Doc+ppHsQualType (HsQualType [] htype) = ppHsType htype+ppHsQualType (HsQualType context htype) = -- if it's HsQualType, context is never empty+	     myFsep [ ppHsContext context, text "=>", ppHsType htype]++parensIf :: Bool -> Doc -> Doc+parensIf True = parens+parensIf False = id++instance P.PPrint Doc HsType where+    pprint = ppHsType++ppHsType :: HsType -> Doc+ppHsType = ppHsTypePrec 0++ppHsTypeArg :: HsType -> Doc+ppHsTypeArg = ppHsTypePrec 2++-- precedences:+-- 0: top level+-- 1: left argument of ->+-- 2: argument of constructor++ppHsTypePrec :: Int -> HsType -> Doc+ppHsTypePrec p (HsTyFun a b) =+	parensIf (p > 0) $+		myFsep [ppHsTypePrec 1 a, text "->", ppHsType b]+ppHsTypePrec p (HsTyAssoc) = text "<assoc>"+ppHsTypePrec p (HsTyEq a b) =+	parensIf (p > 0) $ myFsep [ppHsType a, text "=", ppHsType b]+ppHsTypePrec p (HsTyTuple l) = parenList . map ppHsType $ l+ppHsTypePrec p (HsTyUnboxedTuple l) = parenListzh . map ppHsType $ l+-- special case+ppHsTypePrec p (HsTyApp (HsTyCon lcons) b ) | lcons == nameName tc_List = brackets $ ppHsType b+ppHsTypePrec p (HsTyApp a b) =+	parensIf (p > 1) $ myFsep[ppHsType a, ppHsTypeArg b]+ppHsTypePrec p (HsTyVar name) = ppHsName name+-- special case+ppHsTypePrec p (HsTyCon name) = ppHsQName name+ppHsTypePrec p HsTyForall { hsTypeVars = vs, hsTypeType = qt } = parensIf (p > 1) $ do+    pp <- ppHsQualType qt+    return $ DL.text "forall" DL.<+> DL.hsep (map pprint vs) DL.<+> DL.char '.' DL.<+> pp+ppHsTypePrec p HsTyExists { hsTypeVars = vs, hsTypeType = qt } = parensIf (p > 1) $ do+    pp <- ppHsQualType qt+    return $ DL.text "exists" DL.<+> DL.hsep (map pprint vs) DL.<+> DL.char '.' DL.<+> pp+ppHsTypePrec _ HsTyExpKind { hsTyLType = Located _ t, hsTyKind = k } = do+    t <- ppHsType t+    return $ DL.parens ( t DL.<+> DL.text "::" DL.<+> pprint k)+ppHsTypePrec _ _ = error "HsPretty.ppHsTypePrec: bad."++instance DL.DocLike d => P.PPrint d HsKind where+    pprint (HsKind k) = pprint k+    pprint (HsKindFn (HsKind k) t) = pprint k DL.<+> DL.text "->" DL.<+> pprint t+    pprint (HsKindFn a b) = DL.parens (pprint a) DL.<+> DL.text "->" DL.<+> pprint b++------------------------- Expressions -------------------------+ppHsRhs :: HsRhs -> Doc+ppHsRhs (HsUnGuardedRhs exp) = equals <+> ppHsExp exp+ppHsRhs (HsGuardedRhss guardList) =+	myVcat . map ppHsGuardedRhs $ guardList++ppHsGuardedRhs :: HsGuardedRhs -> Doc+ppHsGuardedRhs (HsGuardedRhs pos guard body) =+	       myFsep [ char '|',+		      ppHsExp guard,+		      equals,+		      ppHsExp body]++{-# NOINLINE ppHsLit #-}+ppHsLit :: HsLiteral -> Doc+ppHsLit	(HsInt i)      = integer i+ppHsLit	(HsChar c)     = text (show c)+ppHsLit	(HsString s)   = text (show s)+ppHsLit	(HsFrac r)     = double (fromRational r)+-- GHC unboxed literals:+ppHsLit (HsCharPrim c)   = text (show c)           <> char '#'+ppHsLit (HsStringPrim s) = text (show s)           <> char '#'+ppHsLit (HsIntPrim i)    = integer i               <> char '#'+ppHsLit (HsFloatPrim r)  = float  (fromRational r) <> char '#'+ppHsLit (HsDoublePrim r) = double (fromRational r) <> text "##"+-- GHC extension:+ppHsLit (HsLitLit s)     = text "''" <> text s <> text "''"++{-# NOINLINE ppHsExp #-}+ppHsExp :: HsExp -> Doc+ppHsExp (HsLit l) = ppHsLit l+-- lambda stuff+ppHsExp (HsInfixApp a op b) = myFsep[ppHsExp a, ppInfix op, ppHsExp b]+	where+	ppInfix (HsAsPat as (HsVar n)) | dump FD.Aspats = ppHsName as <> char '@' <> ppHsQNameInfix n+	ppInfix (HsAsPat _ (HsVar n)) = ppHsQNameInfix n+	ppInfix (HsAsPat as (HsCon n)) | dump FD.Aspats = ppHsName as <> char '@' <> ppHsQNameInfix n+	ppInfix (HsAsPat _ (HsCon n)) = ppHsQNameInfix n+	ppInfix (HsVar n) = ppHsQNameInfix n+	ppInfix (HsCon n) = ppHsQNameInfix n+	ppInfix n = error $ "illegal infix expression: " ++ show n+ppHsExp (HsNegApp e) = myFsep [char '-', ppHsExp e]+ppHsExp (HsApp a b) = myFsep [ppHsExp a, ppHsExp b]+ppHsExp HsError { hsExpString = msg } = text $ "<error:" ++ msg ++ ">"+-- ppHsExp (HsLambda expList body) = myFsep $+ppHsExp (HsLambda _srcLoc expList body) = myFsep $              -- srcLoc added by Bernie+	(((char '\\' ):) . map ppHsPat $ expList)+	++ [text "->", ppHsExp body]+-- keywords+ppHsExp (HsLet expList letBody) =+	myFsep [text "let" <+> body letIndent (map ppHsDecl expList),+		text "in", ppHsExp letBody]+ppHsExp (HsIf cond thenexp elsexp) =+	myFsep [text "if", ppHsExp cond,+	      text "then", ppHsExp thenexp,+	      text "else", ppHsExp elsexp]+ppHsExp (HsCase cond altList) = myFsep[text "case", ppHsExp cond, text "of"]+			        $$$ body caseIndent (map ppHsAlt altList)+ppHsExp (HsDo stmtList) = text "do" $$$ body doIndent (map ppHsStmt stmtList)+-- Constructors & Vars+ppHsExp (HsVar name ) = ppHsQNameParen name+ppHsExp (HsCon name) = ppHsQNameParen name+ppHsExp (HsTuple expList) = parenList . map ppHsExp $ expList+ppHsExp (HsUnboxedTuple expList) = parenListzh . map ppHsExp $ expList+-- weird stuff+ppHsExp (HsParen exp) = parens . ppHsExp $ exp+ppHsExp (HsLeftSection v exp)   | (HsVar name) <- dropAs v =+	parens (ppHsExp exp <+> ppHsQNameInfix name)+ppHsExp (HsLeftSection v exp)   | (HsCon name) <- dropAs v =+	parens (ppHsExp exp <+> ppHsQNameInfix name)+ppHsExp (HsLeftSection _ _) = error "illegal left section"+ppHsExp (HsRightSection exp v) | (HsVar name) <- dropAs v =+	parens (ppHsQNameInfix name <+> ppHsExp exp)+ppHsExp (HsRightSection exp v) | (HsCon name) <- dropAs v =+	parens (ppHsQNameInfix name <+> ppHsExp exp)+ppHsExp (HsRightSection _ _) = error "illegal right section"+ppHsExp (HsRecConstr c fieldList) =+	ppHsQName c+        <> (braceList . map ppHsFieldUpdate  $ fieldList)+ppHsExp (HsRecUpdate exp fieldList) =+	ppHsExp exp+        <> (braceList . map ppHsFieldUpdate  $ fieldList)+-- patterns+-- special case that would otherwise be buggy+ppHsExp (HsAsPat _ p) | not (dump FD.Aspats) = ppHsExp p+ppHsExp (HsAsPat name (HsIrrPat (Located _ exp))) =+	myFsep[ppHsName name <> char '@', char '~' <> ppHsExp exp]+ppHsExp (HsAsPat name exp) = hcat[ppHsName name,char '@',ppHsExp exp]+ppHsExp (HsWildCard _) = char '_'+ppHsExp (HsIrrPat (Located _ exp)) = char '~' <> ppHsExp exp+ppHsExp (HsBangPat (Located _ exp)) = char '!' <> ppHsExp exp+-- Lists+ppHsExp (HsList list) =+	bracketList . punctuate comma . map ppHsExp $ list+ppHsExp (HsEnumFrom exp) =+	bracketList [ppHsExp exp,text ".."]+ppHsExp (HsEnumFromTo from to) =+	bracketList [ppHsExp from, text "..", ppHsExp to]+ppHsExp (HsEnumFromThen from thenE) =+	bracketList [ppHsExp from <> comma, ppHsExp thenE]+ppHsExp (HsEnumFromThenTo from thenE to) =+	bracketList [ppHsExp from <> comma, ppHsExp thenE,+			text "..", ppHsExp to]+ppHsExp (HsListComp exp stmtList) =+	bracketList ([ppHsExp exp, char '|']+		++ (punctuate comma . map ppHsStmt $ stmtList))+ppHsExp (HsExpTypeSig pos exp ty) =+	myFsep[ppHsExp exp, text "::", ppHsQualType ty]+ppHsExp (HsLocatedExp (Located _ x)) = ppHsExp x++------------------------- Patterns -----------------------------++ppHsPat :: HsPat -> Doc+ppHsPat (HsPVar name) = ppHsNameParen name+ppHsPat (HsPLit lit) = ppHsLit lit+ppHsPat (HsPNeg p) = myFsep [char '-', ppHsPat p]+ppHsPat (HsPInfixApp a op b) = myFsep[ppHsPat a, ppHsQNameInfix op, ppHsPat b]+ppHsPat (HsPApp n ps) = myFsep (ppHsQName n : map ppHsPat ps)+ppHsPat (HsPTuple ps) = parenList . map ppHsPat $ ps+ppHsPat (HsPUnboxedTuple ps) = parenListzh . map ppHsPat $ ps+ppHsPat (HsPList ps) = bracketList . punctuate comma . map ppHsPat $ ps+ppHsPat (HsPParen p) = parens . ppHsPat $ p+ppHsPat (HsPRec c fields)+    =  ppHsQName c+    <> (braceList . map ppHsPatField $ fields)+-- special case that would otherwise be buggy+ppHsPat (HsPAsPat name (HsPIrrPat (Located _ pat))) =+	myFsep[ppHsName name <> char '@', char '~' <> ppHsPat pat]+ppHsPat	(HsPAsPat name pat) = hcat[ppHsName name,char '@',ppHsPat pat]+ppHsPat	HsPWildCard = char '_'+ppHsPat	(HsPIrrPat (Located _ pat)) = char '~' <> ppHsPat pat+ppHsPat	~(HsPBangPat (Located _ pat)) = char '!' <> ppHsPat pat++ppHsPatField (HsPFieldPat name pat) = myFsep[ppHsQName name, equals, ppHsPat pat]++------------------------- Case bodies  -------------------------+ppHsAlt :: HsAlt -> Doc+ppHsAlt (HsAlt pos exp gAlts decls) =+	ppHsPat exp <+> ppGAlts gAlts $$$ ppWhere decls++ppGAlts :: HsRhs -> Doc+ppGAlts (HsUnGuardedRhs exp) = text "->" <+> ppHsExp exp+ppGAlts (HsGuardedRhss altList) = myVcat . map ppGAlt $ altList++ppGAlt (HsGuardedRhs pos exp body) =+	 myFsep [char '|', ppHsExp exp, text "->", ppHsExp body]++------------------------- Statements in monads & list comprehensions -----+ppHsStmt :: HsStmt -> Doc+ppHsStmt (HsGenerator _sloc exp from) =                    -- sloc added by Bernie+	 ppHsPat exp <+> text "<-" <+> ppHsExp from+ppHsStmt (HsQualifier exp) = ppHsExp exp+ppHsStmt (HsLetStmt declList) = text "let"+				$$$ body letIndent (map ppHsDecl declList)++------------------------- Record updates+ppHsFieldUpdate :: HsFieldUpdate -> Doc+ppHsFieldUpdate (HsFieldUpdate name exp) =+		  myFsep[ppHsQName name,equals,ppHsExp exp]++------------------------- Names -------------------------+ppHsQName :: HsName -> Doc+ppHsQName n = text $ show n+--ppHsQName (UnQual name)			= ppHsIdentifier name+--ppHsQName z@(Qual m@(Module mod) name)+--	 | otherwise = text mod <> char '.' <> ppHsIdentifier name++ppHsName = ppHsQName++ppHsQNameParen :: HsName -> Doc+ppHsQNameParen name = parensIf (isSymbolName name) (ppHsQName name)++ppHsQNameInfix :: HsName -> Doc+ppHsQNameInfix name+	| isSymbolName name = ppHsQName name+	| otherwise = char '`' <> ppHsQName name <> char '`'++--ppHsIdentifier :: HsIdentifier -> Doc+--ppHsIdentifier name = text (show name)++ppHsNameParen :: HsName -> Doc+ppHsNameParen name = parensIf (isSymbolName name) (ppHsName name)++ppHsNameInfix :: HsName -> Doc+ppHsNameInfix name+	| isSymbolName name = ppHsName name+	| otherwise = char '`' <> ppHsName name <> char '`'++isSymbolName :: HsName -> Bool+--isSymbolName (Qual _ (HsSymbol _)) = True+--isSymbolName (UnQual (HsSymbol _)) = True+isSymbolName x | (_,_,c:_) <- nameParts (unRename x), isAlpha c || c `elem` "'_" = False+isSymbolName _ = True++ppHsContext :: HsContext -> Doc+ppHsContext []      = empty+ppHsContext context = parenList (map ppHsAsst context)++-- hacked for multi-parameter type classes++ppHsAsst :: HsAsst -> Doc+--ppHsAsst (a,ts) = myFsep(ppHsQName a : map ppHsTypeArg ts)+ppHsAsst (HsAsst a ts) = myFsep(ppHsQName a : map ppHsName ts)+ppHsAsst (HsAsstEq a b) = ppHsType a <+> char '=' <+> ppHsType b++------------------------- pp utils -------------------------+maybePP :: (a -> Doc) -> Maybe a -> Doc+maybePP pp Nothing = empty+maybePP pp (Just a) = pp a++parenList :: [Doc] -> Doc+parenList = parens . myFsepSimple . punctuate comma+parenListzh :: [Doc] -> Doc+parenListzh = parenszh . myFsepSimple . punctuate comma++braceList :: [Doc] -> Doc+braceList = braces . myFsepSimple . punctuate comma++bracketList :: [Doc] -> Doc+bracketList = brackets . myFsepSimple++-- Monadic PP Combinators -- these examine the env++topLevel :: Doc -> [Doc] -> Doc+topLevel header dl = do+	 e <- fmap layout getPPEnv+	 case e of+	     PPOffsideRule -> header $$ vcat dl+	     PPSemiColon -> header $$ (braces . vcat . punctuate semi) dl+	     PPInLine -> header $$ (braces . vcat . punctuate semi) dl+	     PPNoLayout -> header <+> (braces . hsep . punctuate semi) dl++body :: (PPHsMode -> Int) -> [Doc] -> Doc+body f dl = do+	 e <- fmap layout getPPEnv+	 case e of PPOffsideRule -> indent+		   PPSemiColon   -> indentExplicit+		   _ -> inline+		   where+		   inline = braces . hsep . punctuate semi $ dl+		   indent  = do{i <-fmap f getPPEnv;nest i . vcat $ dl}+		   indentExplicit = do {i <- fmap f getPPEnv;+			   nest i . braces . vcat . punctuate semi $ dl}++($$$) :: Doc -> Doc -> Doc+a $$$ b = layoutChoice (a $$) (a <+>) b++mySep :: [Doc] -> Doc+mySep = layoutChoice mySep' hsep+	where+	-- ensure paragraph fills with indentation.+	mySep' [x]    = x+	mySep' (x:xs) = x <+> fsep xs+	mySep' []     = error "Internal error: mySep"++myVcat :: [Doc] -> Doc+myVcat = layoutChoice vcat hsep++myFsepSimple :: [Doc] -> Doc+myFsepSimple = layoutChoice fsep hsep++-- same, except that continuation lines are indented,+-- which is necessary to avoid triggering the offside rule.+myFsep :: [Doc] -> Doc+myFsep = layoutChoice fsep' hsep+	where	fsep' [] = empty+		fsep' (d:ds) = do+			e <- getPPEnv+			let n = onsideIndent e+			nest n (fsep (nest (-n) d:ds))++layoutChoice a b dl = do e <- getPPEnv+                         if layout e == PPOffsideRule ||+                            layout e == PPSemiColon+                          then a dl else b dl++instance P.PPrint P.Doc HsDecl where+    pprint d = unDocM (ppHsDecl d) defaultMode++instance P.PPrint P.Doc HsExp where+    pprint d = unDocM (ppHsExp d) defaultMode++instance P.PPrint P.Doc HsType where+    pprint d = unDocM (ppHsType d) defaultMode++instance P.PPrint P.Doc HsQualType where+    pprint d = unDocM (ppHsQualType d) defaultMode++instance P.PPrint P.Doc  HsTyVarBind where+   pprint d = P.text (show $ hsTyVarBindName d)++instance P.PPrint P.Doc  HsPat where+    pprint d = unDocM (ppHsPat d) defaultMode
+ src/FrontEnd/Infix.hs view
@@ -0,0 +1,331 @@+{-------------------------------------------------------------------------------++        Copyright:              The Hatchet Team (see file Contributors)++        Module:                 Infix++        Description:            Patches the abstract syntax description with+                                the infix precedence and associativity rules+                                for identifiers in the module.++                                The main tasks implemented by this module are:++        Primary Authors:        Lindsay Powles++        Notes:                  See the file License for license information++-------------------------------------------------------------------------------}++module FrontEnd.Infix (buildFixityMap, infixHsModule, FixityMap,size, infixStatement, restrictFixityMap) where++import Data.Binary+import Data.Monoid+import qualified Data.Map as Map++import FrontEnd.HsSyn+import Name.Name+import Support.MapBinaryInstance+import Util.HasSize++----------------------------------------------------------------------------++type FixityInfo = (Int, HsAssoc)+type SymbolMap = Map.Map Name FixityInfo++newtype FixityMap = FixityMap SymbolMap+    deriving(Monoid,HasSize)++instance Binary FixityMap where+    put (FixityMap ts) = putMap ts+    get = fmap FixityMap getMap++restrictFixityMap :: (Name -> Bool) -> FixityMap -> FixityMap+restrictFixityMap f (FixityMap fm) = FixityMap (Map.filterWithKey (\k _ -> f k) fm)+++----------------------------------------------------------------------------+++ -- Some constants:++syn_err_msg :: String+syn_err_msg = "Syntax error in input, run through a compiler to check.\n"++syn_err_bad_oparg op exp =    syn_err_msg ++ "\tERROR: cannot apply " ++ show op+                           ++ " to the expression: " ++ show exp++syn_err_precedence op exp =    syn_err_msg ++ "\tERROR: the precedence of " ++ show op+                            ++ " is incompatible with the precendence of it's argument: " ++ show exp++defaultFixity :: (Int, HsAssoc)     -- Fixity assigned to operators without explict infix declarations.+defaultFixity = (9, HsAssocLeft)++terminalFixity :: (Int, HsAssoc)    -- Fixity given to variables, etc. Used to terminate descent.+terminalFixity = (10, HsAssocLeft)+++----------------------------------------------------------------------------++  -- infixer(): The exported top-level function. See header for usage.++infixHsModule :: FixityMap -> HsModule -> HsModule+infixHsModule (FixityMap ism) m = hsModuleDecls_u f m where+    f = map (processDecl ism)+    --ism = buildSMap is++infixStatement :: FixityMap -> HsStmt -> HsStmt+infixStatement (FixityMap ism) m = processStmt ism m+++++--infixer :: [HsDecl] -> TidyModule -> TidyModule+--infixer infixRules tidyMod =+--    tidyMod { tidyClassDecls = process tidyClassDecls,+--              tidyInstDecls = process tidyInstDecls,+--              tidyFunBinds = process tidyFunBinds,+--              tidyPatBinds = process tidyPatBinds }+--    where+--        process field = map (processDecl infixMap) (field tidyMod)+--        infixMap = buildSMap infixRules+++----------------------------------------------------------------------------++  --  Functions for building and searching the map of operators and their+  -- associated associativity and binding power.++buildFixityMap :: [HsDecl] -> FixityMap+buildFixityMap ds = FixityMap (Map.fromList $ concatMap f ds)  where+        f (HsInfixDecl _ assoc strength names) = zip (map make_key names) $ repeat (strength,assoc)+        f _ = []+        make_key = fromValishHsName+        --make_key a_name = case a_name of+        --    (Qual a_module name)   -> (a_module, name)+        --    (UnQual name)          -> (unqualModule, name)+++--buildSMap infixRules =+--    foldl myAddToFM emptyFM $ concat $ map formatDecl infixRules+--    where+--        formatDecl (HsInfixDecl _ assoc strength names) = zip (map make_key names) $ circList (strength,assoc)+--        formatDecl _ = []+--        circList (str,assc) = (str,assc) : circList (str,assc)+--        myAddToFM fm (k,e) = addToFM fm k e+--        make_key a_name = case a_name of+--            (Qual a_module name)   -> (a_module, name)+--            (UnQual name)          -> (unqualModule, name)++lookupSM infixMap  exp = case exp of+    HsAsPat _ e -> lookupSM infixMap e+    HsVar qname    -> Map.findWithDefault defaultFixity (toName Val qname) infixMap+    HsCon qname    -> Map.findWithDefault defaultFixity (toName DataConstructor qname) infixMap+    _           -> error $ "Operator (" ++ show exp ++ ") is invalid."++--lookupSM infixMap  exp = case exp of+--    HsAsPat _ e -> lookupSM infixMap e+--    HsVar qname    -> case qname of+--                    Qual a_module name -> lookupDftFM infixMap defaultFixity (a_module, name)+--                    UnQual name        -> lookupDftFM infixMap defaultFixity (unqualModule, name)+--    HsCon qname  -> case qname of+--                    Qual a_module name -> lookupDftFM infixMap defaultFixity (a_module, name)+--                    UnQual name        -> lookupDftFM infixMap defaultFixity (unqualModule, name)+--    _           -> error $ "Operator (" ++ show exp ++ ") is invalid."+++-----------------------------------------------------------------------------++  --  Functions used to sift through the syntax to find expressions to+  -- operate on.++processDecl :: SymbolMap -> HsDecl -> HsDecl+processDecl infixMap decl = case decl of+    HsClassDecl    srcloc qualtype decls   -> HsClassDecl srcloc qualtype $ proc_decls decls+    HsInstDecl     srcloc qualtype decls   -> HsInstDecl srcloc qualtype $ proc_decls decls+    HsFunBind      matches                 -> HsFunBind $ map (processMatch infixMap) matches+    HsPatBind      srcloc pat rhs decls    -> HsPatBind srcloc (procPat infixMap pat) (processRhs infixMap rhs) $ proc_decls decls+    HsPragmaRules rs -> HsPragmaRules $ map proc_rule rs+    _                                       -> decl+    where+        proc_decls decls = map (processDecl infixMap) decls+        proc_rule prules@HsRule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2} =+             prules { hsRuleLeftExpr = fst $ processExp infixMap e1, hsRuleRightExpr = fst $ processExp infixMap e2 }+++processMatch :: SymbolMap -> HsMatch -> HsMatch+processMatch infixMap (HsMatch srcloc qname pats rhs decls) =+    HsMatch srcloc qname (map (procPat infixMap) pats) new_rhs new_decls+    where+        new_rhs = processRhs infixMap rhs+        new_decls = map (processDecl infixMap) decls+++processRhs :: SymbolMap -> HsRhs -> HsRhs+processRhs infixMap rhs = case rhs of+    HsUnGuardedRhs exp     -> HsUnGuardedRhs $ fst $ processExp infixMap exp+    HsGuardedRhss  rhss    -> HsGuardedRhss $ map (processGRhs infixMap) rhss+++processGRhs :: SymbolMap -> HsGuardedRhs -> HsGuardedRhs+processGRhs infixMap (HsGuardedRhs srcloc e1 e2) = HsGuardedRhs srcloc new_e1 new_e2+    where+        new_e1 = fst $ processExp infixMap e1+        new_e2 = fst $ processExp infixMap e2+++processAlt :: SymbolMap -> HsAlt -> HsAlt+processAlt infixMap (HsAlt srcloc pat g_alts decls) = HsAlt srcloc (procPat infixMap pat) new_g_alts new_decls+    where+        new_g_alts = processGAlts infixMap g_alts+        new_decls = map (processDecl infixMap) decls+++processGAlts :: SymbolMap -> HsRhs -> HsRhs+processGAlts infixMap g_alts = case g_alts of+    HsUnGuardedRhs exp     -> HsUnGuardedRhs $ fst $ processExp infixMap exp+    HsGuardedRhss galts    -> HsGuardedRhss $ map (processGAlt infixMap) galts+++processGAlt :: SymbolMap -> HsGuardedRhs -> HsGuardedRhs+processGAlt infixMap (HsGuardedRhs srcloc e1 e2) = HsGuardedRhs srcloc new_e1 new_e2+    where+        new_e1 = fst $ processExp infixMap e1+        new_e2 = fst $ processExp infixMap e2+++processStmt :: SymbolMap -> HsStmt -> HsStmt+processStmt infixMap stmt = case stmt of+    HsGenerator srcloc pat exp     -> HsGenerator srcloc (procPat infixMap pat) $ fst $ processExp infixMap exp+    HsQualifier exp                -> HsQualifier $ fst $ processExp infixMap exp+    HsLetStmt decls                -> HsLetStmt $ map (processDecl infixMap) decls+ -- _                           -> error "Bad HsStmt data passed to processStmt."+++processFUpdt :: SymbolMap -> HsFieldUpdate -> HsFieldUpdate+processFUpdt infixMap (HsFieldUpdate qname exp) = HsFieldUpdate qname new_exp+    where+        new_exp = fst $ processExp infixMap exp+++procPat sm p = fst $ processPat sm p+processPat :: SymbolMap -> HsPat -> (HsPat, FixityInfo)+processPat infixMap exp = case exp of+    HsPInfixApp l op r  ->+              case (compare l_power op_power) of+                    GT -> (HsPInfixApp new_l op new_r, op_fixity)+                    EQ -> case op_assoc of+                        HsAssocNone    -> error_precedence op new_l+                        HsAssocRight   -> case l_assoc of+                            HsAssocRight   -> case new_l of+                                HsPInfixApp l' op' r' -> (HsPInfixApp l' op' (process_r' r'), l_fixity)+                                _                     -> error_syntax op new_l+                            _               -> error_precedence op new_l+                        HsAssocLeft    -> case l_assoc of+                            HsAssocLeft    -> (HsPInfixApp new_l op new_r, op_fixity)+                            _               -> error_precedence op new_l+                    LT -> case new_l of+                        HsPInfixApp l' op' r' -> (HsPInfixApp l' op' (process_r' r'), l_fixity)+                        _                     -> error_syntax op new_l+               where+                    (new_l, l_fixity) = processPat infixMap l+                    l_power = fst l_fixity+                    l_assoc = snd l_fixity+                    op_fixity = Map.findWithDefault defaultFixity  (toName DataConstructor op) infixMap+                    op_power = fst op_fixity+                    op_assoc = snd op_fixity+                    new_r = processExp' r+                    process_r' r' = processExp' $ HsPInfixApp r' op r+                    error_precedence err_op err_lower = error $ syn_err_precedence err_op err_lower+                    error_syntax err_op err_lower = error $ syn_err_bad_oparg err_op err_lower+    x@HsPVar {} -> (x,terminalFixity)+    x@HsPLit {} -> (x,terminalFixity)+    x@HsPWildCard  -> (x,terminalFixity)+    HsPNeg p ->    tf $ HsPNeg (pp p)+    HsPIrrPat p -> tf $ HsPIrrPat (fmap pp p)+    HsPBangPat p -> tf $ HsPBangPat (fmap pp p)+    HsPApp n xs -> tf $ HsPApp n (map pp xs)+    HsPTuple xs -> tf $ HsPTuple (map pp xs)+    HsPUnboxedTuple xs -> tf $ HsPUnboxedTuple (map pp xs)+    HsPList xs ->  tf $ HsPList (map pp xs)+    HsPParen xs -> tf $ HsPParen (pp xs)+    HsPRec n xs -> tf $ HsPRec n [ HsPFieldPat n (pp p) | HsPFieldPat n p <- xs ]+    HsPAsPat n p -> tf $ HsPAsPat n (pp p)+    HsPTypeSig sl p qt -> tf $ HsPTypeSig sl (pp p) qt+    where+        processExp' = fst . (processPat infixMap)+        pp = fst . (processPat infixMap)+        tf x = (x,terminalFixity)++-----------------------------------------------------------------------------+++    {- processExp():   Where the syntax tree reshaping actually takes+                     place. Assumes the parser that created the syntax+                     assumed the same binding power and left associativity+                     for all operators. Operators are assumed to be only+                     those that are excepted under the Haskell 98 report+                     and sections are also parsed according to this report+                     aswell (NOT according to how current compilers handle+                     sections!). -}++processExp :: SymbolMap -> HsExp -> (HsExp, FixityInfo)+processExp infixMap exp = case exp of+    HsInfixApp l op r  ->+              case (compare l_power op_power) of+                    GT -> (HsInfixApp new_l op new_r, op_fixity)+                    EQ -> case op_assoc of+                        HsAssocNone    -> error_precedence op new_l+                        HsAssocRight   -> case l_assoc of+                            HsAssocRight   -> case new_l of+                                HsInfixApp l' op' r' -> (HsInfixApp l' op' (process_r' r'), l_fixity)+                                _                     -> error_syntax op new_l+                            _               -> error_precedence op new_l+                        HsAssocLeft    -> case l_assoc of+                            HsAssocLeft    -> (HsInfixApp new_l op new_r, op_fixity)+                            _               -> error_precedence op new_l+                    LT -> case new_l of+                        HsInfixApp l' op' r' -> (HsInfixApp l' op' (process_r' r'), l_fixity)+                        _                     -> error_syntax op new_l+               where+                    (new_l, l_fixity) = processExp infixMap l+                    l_power = fst l_fixity+                    l_assoc = snd l_fixity+                    op_fixity = lookupSM infixMap op+                    op_power = fst op_fixity+                    op_assoc = snd op_fixity+                    new_r = processExp' r+                    process_r' r' = processExp' $ HsInfixApp r' op r+                    error_precedence err_op err_lower = error $ syn_err_precedence err_op err_lower+                    error_syntax err_op err_lower = error $ syn_err_bad_oparg err_op err_lower+    HsApp e1 e2        -> (HsApp (processExp' e1) (processExp' e2), terminalFixity)+    HsNegApp e1        -> (HsNegApp (processExp' e1), terminalFixity)+    HsLet decls e1     -> (HsLet (map (processDecl infixMap) decls) (processExp' e1), terminalFixity)+    HsIf e1 e2 e3      -> (HsIf (processExp' e1) (processExp' e2) (processExp' e3), terminalFixity)+    HsCase e1 alts     -> (HsCase (processExp' e1) (map (processAlt infixMap) alts), terminalFixity)+    HsDo stmts         -> (HsDo (map (processStmt infixMap) stmts), terminalFixity)+    HsTuple exps       -> (HsTuple (map processExp' exps), terminalFixity)+    HsUnboxedTuple exps -> (HsUnboxedTuple (map processExp' exps), terminalFixity)+    HsList exps        -> (HsList (map processExp' exps), terminalFixity)+    HsParen e1         -> (HsParen (processExp' e1), terminalFixity)+    HsEnumFrom e1      -> (HsEnumFrom (processExp' e1), terminalFixity)+    HsEnumFromTo e1 e2 -> (HsEnumFromTo (processExp' e1) (processExp' e2), terminalFixity)+    HsListComp e1 stmts    ->+                           (HsListComp (processExp' e1) (map (processStmt infixMap) stmts), terminalFixity)+    HsAsPat name e1        -> (HsAsPat name (processExp' e1), terminalFixity)+    HsIrrPat e1            -> (HsIrrPat (fmap processExp' e1), terminalFixity)+    HsBangPat e1            -> (HsBangPat (fmap processExp' e1), terminalFixity)+    HsLeftSection e1 e2    -> (HsLeftSection e1 (processExp' e2), terminalFixity)+    HsRightSection e1 e2       -> (HsRightSection (processExp' e1) e2, terminalFixity)+    HsLambda srcloc pats e1    -> (HsLambda srcloc (map (procPat infixMap) pats) (processExp' e1), terminalFixity)+    HsRecConstr qname f_updts  -> (HsRecConstr qname (map (processFUpdt infixMap) f_updts), terminalFixity)+    HsEnumFromThen e1 e2       -> (HsEnumFromThen (processExp' e1) (processExp' e2), terminalFixity)+    HsRecUpdate e1 f_updts     ->+                        (HsRecUpdate (processExp' e1) (map (processFUpdt infixMap) f_updts), terminalFixity)+    HsEnumFromThenTo e1 e2 e3  ->+                        (HsEnumFromThenTo (processExp' e1) (processExp' e2) (processExp' e3), terminalFixity)+    HsExpTypeSig srcloc e1 qtype   -> (HsExpTypeSig srcloc (processExp' e1) qtype, terminalFixity)+    _                   -> (exp, terminalFixity)+    where+        processExp' = fst . (processExp infixMap)++------------------------------------------------------------------------------
+ src/FrontEnd/Lexer.hs view
@@ -0,0 +1,721 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.Lexer+-- Copyright   :  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Lexer for Haskell.+--+-----------------------------------------------------------------------------++-- ToDo: Introduce different tokens for decimal, octal and hexadecimal (?)+-- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?)+-- ToDo: Use a lexical analyser generator (lx?)++module FrontEnd.Lexer (Token(..), lexer) where++import Control.Monad+import Data.Char hiding(isSymbol)+import Data.Ratio+import qualified Data.Char+import qualified Data.Map as Map+import qualified Data.Set as Set++import FrontEnd.ParseMonad+import FrontEnd.SrcLoc+import FrontEnd.Warning+import Name.Name+import Options+import PackedString+import Util.SetLike+import qualified FlagOpts as FO++data Token+    = VarId      !Name+    | QVarId     !Name+    | ConId      !Name+    | QConId     !Name+    | VarSym     !Name+    | ConSym     !Name+    | QVarSym    !Name+    | QConSym    !Name+    | IntTok     !Integer+    | UIntTok    !Integer+    | FloatTok   !Rational+    | Character  !Char+    | UCharacter !Char+    | StringTok  String+    | UStringTok String+    | PragmaOptions [String]+    | PragmaInline  String+    | PragmaExp     String+    | PragmaRules   !Bool+    | PragmaSpecialize !Bool+    | PragmaStart String+    | PragmaEnd+-- Symbols+    | LeftParen+    | RightParen+    | LeftUParen+    | RightUParen+    | SemiColon+    | LeftCurly+    | RightCurly+    | VRightCurly -- a virtual close brace+    | LeftSquare+    | RightSquare+    | Comma+    | Underscore+    | BackQuote+-- Reserved operators+    | DotDot+    | Colon+    | DoubleColon+    | Equals+    | Backslash+    | Bar+    | LeftArrow+    | RightArrow+    | At+    | Tilde+    | DoubleArrow+    | Minus+    | Quest+    | QuestQuest+    | StarBang+    | Exclamation+    | BangExclamation+    | Star+    | Hash+    | Dot+-- Reserved Ids+    | KW_As+    | KW_Case+    | KW_Class+    | KW_Alias+    | KW_Data+    | KW_Default+    | KW_Deriving+    | KW_Do+    | KW_Else+    | KW_Hiding+    | KW_If+    | KW_Import+    | KW_In+    | KW_Infix+    | KW_InfixL+    | KW_InfixR+    | KW_Instance+    | KW_Let+    | KW_Module+    | KW_NewType+    | KW_Of+    | KW_Then+    | KW_Type+    | KW_Where+    | KW_Qualified+    | KW_Foreign+    | KW_Forall+    | KW_Exists+    | KW_Kind+    | KW_Family+    | KW_Closed+    | EOF++reserved_ops :: Map.Map Name Token+reserved_ops = procMap [+ ( "..", DotDot ),+ -- ( ":",  Colon ),+ ( "::", DoubleColon ),+ ( "=",  Equals ),+ ( "\\", Backslash ),+ ( "|",  Bar ),+ ( "<-", LeftArrow ),+ ( "->", RightArrow ),+ ( "@",  At ),+ ( "~",  Tilde ),+ ( "=>", DoubleArrow ),+ ( [chr 0x2192], RightArrow ),  -- →+ ( [chr 0x2190], LeftArrow ),   -- ←+ ( [chr 0x2237], DoubleColon ), -- ∷+ ( [chr 0x2025], DotDot ),      -- ‥+ ( [chr 0x21d2], DoubleArrow )  -- ⇒+ ]++special_varops :: Map.Map Name Token+special_varops = procMap [+ ( "-",  Minus ),	--ToDo: shouldn't be here+ ( "?",  Quest ),     --ditto+ ( "??", QuestQuest ),--ditto+ ( "*!", StarBang ),--ditto+ ( "!",  Exclamation ),	--ditto+ ( ".",  Dot ),		--ditto+ ( "*",  Star ),	--ditto+ ( "\x2605",  Star ),	--ditto+ ( "#",  Hash )		--ditto+ ]++procMap :: [(String,Token)] -> Map.Map Name Token+procMap xs = fromList $ map f xs where+    f (x,y) = (toUnqualName x,y)++reserved_ids :: Map.Map Name Token+reserved_ids = procMap [+ ( "_",         Underscore ),+ ( "case",      KW_Case ),+ ( "class",     KW_Class ),+ ( "alias",     KW_Alias ),+ ( "data",      KW_Data ),+ ( "default",   KW_Default ),+ ( "deriving",  KW_Deriving ),+ ( "do",        KW_Do ),+ ( "else",      KW_Else ),+ ( "if",    	KW_If ),+ ( "import",    KW_Import ),+ ( "in", 	KW_In ),+ ( "infix", 	KW_Infix ),+ ( "infixl", 	KW_InfixL ),+ ( "infixr", 	KW_InfixR ),+ ( "instance",  KW_Instance ),+ ( "let", 	KW_Let ),+ ( "module", 	KW_Module ),+ ( "newtype",   KW_NewType ),+ ( "of", 	KW_Of ),+ ( "then", 	KW_Then ),+ ( "type", 	KW_Type ),+ ( "\x2200",    KW_Forall ),+ ( ['∃'],       KW_Exists ),+ ( "where", 	KW_Where )+ ]++special_varids :: Map.Map Name Token+special_varids = procMap [+ ( "as", 	KW_As ),+ ( "closed", 	KW_Closed ),+ ( "qualified", KW_Qualified ),+ ( "hiding", 	KW_Hiding ),+ ( "forall",    KW_Forall )+ ]++-- these become keywords when the cooresponding extensions are enabled.+optional_ids = procOpt [+ ( "kind", KW_Kind, FO.UserKinds ),+ ( "foreign", KW_Foreign, FO.Ffi ),+ ( "family", KW_Family, FO.TypeFamilies ),+ ( "forall", KW_Forall, FO.Forall ),+ ( "exists", KW_Exists, FO.Exists),+ ( "!"     , BangExclamation, FO.BangPatterns )+ ]++procOpt xs = Map.fromList [ (toUnqualName w,(o,k)) | (w,k,o) <- xs ]++isIdent :: Char -> Bool+isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'++isSymbol :: Char -> Bool+isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~" || (not (isAscii c) && Data.Char.isSymbol c)++matchChar :: Char -> String -> Lex a ()+matchChar c msg = do+	s <- getInput+	if null s || head s /= c then fail msg else discard 1++-- The top-level lexer.+-- We need to know whether we are at the beginning of the line to decide+-- whether to insert layout tokens.++lexer :: (Token -> P a) -> P a+lexer = runL topLexer++topLexer :: Lex a Token+topLexer = do+    b <- pullCtxtFlag+    if b+     then setBOL >> return VRightCurly -- the lex context state flags that we must do an empty {} - UGLY+     else do+    bol <- checkBOL+    bol <- lexWhiteSpace bol+    startToken+    if bol then lexBOL else lexToken++lexWhiteSpace :: Bool -> Lex a Bool+lexWhiteSpace bol = do+    let linePragma = do+            lexWhile (`elem` " \r\t")+            v <- lexDecimal+            lexWhile (`elem` " \r\t")+            s <- getInput+            fn <- case s of+                '"':_ -> do+                    discard 1+                    StringTok s <- lexString+                    return (Just s)+                _ -> return Nothing+            -- discard any "flags" at end of line ...+            lexWhile (`elem` " \r\t")+            lexWhile (isDigit)+            setFilePos (fromInteger v - 1) 1 fn+            lexWhiteSpace False+    s <- getInput+    case s of+        '{':'-':'#':s+            | pname `Map.member` pragmas -> return bol+            | otherwise -> do+                when (pname `Set.notMember` pragmas_ignored) $+                    addWarn (UnknownPragma $ packString pname) $ "The pragma '" ++ pname ++ "' is unknown"+                discard 2+                bol <- lexNestedComment bol+                lexWhiteSpace bol+               where pname =  takeWhile isIdent (dropWhile isSpace s)+        '{':'-':_ -> do+            discard 2+            bol <- lexNestedComment bol+            lexWhiteSpace bol+        '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do+            lexWhile (== '-')+            lexWhile (/= '\n')+            s' <- getInput+            case s' of+                -- [] -> fail "Unterminated end-of-line comment"+                _  -> lexWhiteSpace False+        '\n':'#':' ':ns -> discard 2 >> linePragma+        '\n':'#':'l':'i':'n':'e':' ':ns -> discard 6 >> linePragma+        '\n':_ -> do+            lexNewline+            lexWhiteSpace True+        '\t':_ -> do+            lexTab+            lexWhiteSpace bol+        c:_ | isSpace c -> do+            discard 1+            lexWhiteSpace bol+        _ -> return bol++setFilePos :: Int -> Int -> Maybe String -> Lex a ()+setFilePos line column ms = do+    sl <- getSrcLoc+    let sl' = sl { srcLocLine = line, srcLocColumn = column }+    case ms of+        Just fn -> setSrcLoc sl' { srcLocFileName = packString fn }+        Nothing -> setSrcLoc sl'++lexNestedComment :: Bool -> Lex a Bool+lexNestedComment bol = do+	s <- getInput+	case s of+	    '-':'}':_ -> discard 2 >> return bol+	    '{':'-':_ -> do+		discard 2+		bol <- lexNestedComment bol	-- rest of the subcomment+		lexNestedComment bol		-- rest of this comment+	    '\t':_    -> lexTab >> lexNestedComment bol+	    '\n':_    -> lexNewline >> lexNestedComment True+	    _:_       -> discard 1 >> lexNestedComment bol+	    []        -> fail "Unterminated nested comment"++lexRawPragma ::  String -> Lex a Token+lexRawPragma w = rp [] where+    rp c = do+	s <- getInput+	case s of+	    '#':'-':'}':_ | w == "OPTIONS"  -> discard 3 >> return (PragmaOptions (words $ reverse c))+	--    '#':'-':'}':_ -> discard 3 >> return (PragmaRaw w (reverse c))+	    '#':'-':'}':_ -> fail "Unknown raw pragma"+	    '\t':_    -> lexTab >> rp ('\t':c)+	    '\n':_    -> lexNewline >> rp ('\n':c)+	    x:_       -> discard 1 >> rp (x:c)+	    []        -> fail "Unterminated raw pragma"++-- When we are lexing the first token of a line, check whether we need to+-- insert virtual semicolons or close braces due to layout.++lexBOL :: Lex a Token+lexBOL = do+	pos <- getOffside+	case pos of+	    LT -> do+                -- trace "layout: inserting '}'\n" $+        	-- Set col to 0, indicating that we're still at the+        	-- beginning of the line, in case we need a semi-colon too.+        	-- Also pop the context here, so that we don't insert+        	-- another close brace before the parser can pop it.+		setBOL+		popContextL "lexBOL"+		return VRightCurly+	    EQ ->+                -- trace "layout: inserting ';'\n" $+		return SemiColon+	    GT ->+		lexToken++lexToken :: Lex a Token+lexToken = do+    s <- getInput+    ParseMode { parseUnboxedValues = uval, parseUnboxedTuples = utup, parseOpt = opt } <- lexParseMode+    let opt_ids = Map.mapMaybe f optional_ids where+            f (fo,k) = if fo `Set.member` optFOptsSet opt+                then Just k else Nothing+    case s of+        [] -> return EOF+        '(':'#':_ | utup -> do+            discard 2+            return LeftUParen+        '#':')':_ | utup -> do+            discard 2+            return RightUParen+        '{':'-':'#':s' -> do+            discard 3+            lexWhile isSpace+            w <- lexWhile isIdent+            case normPragma w  of+                Right t -> return t+                Left w' -> lexRawPragma w'+        '#':'-':'}':_ -> do+            discard 3+            return PragmaEnd++	'0':c:d:_ | toLower c == 'o' && isOctDigit d -> do+			discard 2+			n <- lexOctal+			return (IntTok n)+		  | toLower c == 'x' && isHexDigit d -> do+			discard 2+			n <- lexHexadecimal+                        rest <- getInput+                        case rest of+                            '#':_ | uval -> discard 1 >> return (UIntTok n)+                            _ -> return (IntTok n)++	c:_ | isDigit c -> lexDecimalOrFloat++	    | isUpper c -> lexConIdOrQual ""++	    | isLower c || c == '_' || generalCategory c == OtherLetter -> do+		(toUnqualName -> ident) <- lexWhile isIdent+		case Map.lookup ident (opt_ids `Map.union` reserved_ids `Map.union` special_varids) of+                        Just KW_Do -> setFlagDo >> return KW_Do+			Just keyword -> return keyword+			Nothing -> return $ VarId ident++	    | isSymbol c -> do+		sym <- lexWhile isSymbol+                let nsym = toUnqualName sym+		return $ case Map.lookup nsym (opt_ids `Map.union` reserved_ops `Map.union` special_varops) of+			Just t  -> t+			Nothing -> case c of+			    ':' -> ConSym nsym+			    _   -> VarSym nsym++	    | otherwise -> do+		discard 1+		case c of++		    -- First the special symbols+		    '(' ->  return LeftParen+		    ')' ->  return RightParen+		    ',' ->  return Comma+		    ';' ->  return SemiColon+		    '[' ->  return LeftSquare+		    ']' ->  return RightSquare+		    '`' ->  return BackQuote+		    '{' -> do+			    pushContextL NoLayout+			    return LeftCurly+		    '}' -> do+			    popContextL "lexToken"+			    return RightCurly++		    '\'' -> do+			    c2 <- lexChar+			    matchChar '\'' "Improperly terminated character constant"+                            rest <- getInput+                            case rest of+                                --'#':_ | uval -> discard 1 >> return (UIntTok $ fromIntegral $ ord c2)+                                '#':_ | uval -> discard 1 >> return (UCharacter c2)+                                _ -> return (Character c2)++		    '"' ->  lexString++		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")++lexDecimalOrFloat :: Lex a Token+lexDecimalOrFloat = do+    ParseMode { parseUnboxedValues = uval } <- lexParseMode+    let ld ds' = do+            ds <- lexWhile isDigit+            rest <- getInput+            case rest of+                ('_':_) -> discard 1 >> ld (ds' ++ ds)+                rest -> return (ds' ++ ds,rest)+    (ds,rest) <- ld []+    case rest of+        ('.':d:_) | isDigit d -> do+            discard 1+            frac <- lexWhile isDigit+            let num = parseInteger 10 (ds ++ frac)+                decimals = toInteger (length frac)+            exponent <- do+                    rest2 <- getInput+                    case rest2 of+                        e:pm:d:_ | e `elem` "eE", (pm `elem` "+-" && isDigit d) || isDigit pm -> lexExponent+--                        'e':_ -> lexExponent+ --                       'E':_ -> lexExponent+                        _     -> return 0+            return (FloatTok ((num%1) * 10^^(exponent - decimals)))+        e:_ | toLower e == 'e' -> do+            exponent <- lexExponent+            return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent))+        '#':_ | uval -> discard 1 >> return (UIntTok (parseInteger 10 ds))+        _ -> return (IntTok (parseInteger 10 ds))++    where+	lexExponent :: Lex a Integer+	lexExponent = do+		discard 1	-- 'e' or 'E'+		r <- getInput+		case r of+		    '+':d:_ | isDigit d -> do+			discard 1+			lexDecimal+		    '-':d:_ | isDigit d -> do+			discard 1+			n <- lexDecimal+			return (negate n)+		    d:_ | isDigit d -> lexDecimal+		    _ -> fail "Float with missing exponent"++lexConIdOrQual :: String -> Lex a Token+lexConIdOrQual qual = do+	con <- lexWhile isIdent+	let conid | null qual = ConId (toUnqualName con)+		  | otherwise = QConId (toName UnknownType (qual,con))+	    qual' | null qual = con+		  | otherwise = qual ++ '.':con+	just_a_conid <- alternative (return conid)+	rest <- getInput+	case rest of+	  '.':c:_+	     | isLower c || c == '_' -> do	-- qualified varid?+		discard 1+		ident <- lexWhile isIdent+		case Map.lookup (toUnqualName ident) reserved_ids of+		   -- cannot qualify a reserved word+		   Just _  -> just_a_conid+		   Nothing -> return (QVarId $ toName UnknownType (qual', ident))++	     | isUpper c -> do		-- qualified conid?+		discard 1+		lexConIdOrQual qual'++	     | isSymbol c -> do	-- qualified symbol?+		discard 1+		sym <- lexWhile isSymbol+                let nsym = toUnqualName sym+		case Map.lookup nsym reserved_ops of+		    -- cannot qualify a reserved operator+		    Just _  -> just_a_conid+		    Nothing -> return $ case c of+			':' -> QConSym $ toName UnknownType (qual', sym)+			_   -> QVarSym $ toName UnknownType (qual', sym)++	  _ ->	return conid -- not a qualified thing++lexChar :: Lex a Char+lexChar = do+	r <- getInput+	case r of+		'\\':_	-> lexEscape+		c:_	-> discard 1 >> return c+		[]	-> fail "Incomplete character constant"++lexString :: Lex a Token+lexString = do+    ParseMode { parseUnboxedValues = uval } <- lexParseMode+    let loop s = do+		r <- getInput+		case r of+		    '\\':'&':_ -> do+				discard 2+				loop s+		    '\\':c:_ | isSpace c -> do+				discard 1+				lexWhiteChars+				matchChar '\\' "Illegal character in string gap"+				loop s+			     | otherwise -> do+				ce <- lexEscape+				loop (ce:s)+		    '"':'#':_ | uval -> do+				discard 2+				return (UStringTok (reverse s))+		    '"':_ -> do+				discard 1+				return (StringTok (reverse s))+		    c:_ -> do+				discard 1+				loop (c:s)+		    [] ->	fail "Improperly terminated string"++	lexWhiteChars :: Lex a ()+	lexWhiteChars = do+		s <- getInput+		case s of+		    '\n':_ -> do+			lexNewline+			lexWhiteChars+		    '\t':_ -> do+			lexTab+			lexWhiteChars+		    c:_ | isSpace c -> do+			discard 1+			lexWhiteChars+		    _ -> return ()+    loop ""++lexEscape :: Lex a Char+lexEscape = do+	discard 1+	r <- getInput+	case r of++-- Production charesc from section B.2 (Note: \& is handled by caller)++		'a':_		-> discard 1 >> return '\a'+		'b':_		-> discard 1 >> return '\b'+		'f':_		-> discard 1 >> return '\f'+		'n':_		-> discard 1 >> return '\n'+		'r':_		-> discard 1 >> return '\r'+		't':_		-> discard 1 >> return '\t'+		'v':_		-> discard 1 >> return '\v'+		'\\':_		-> discard 1 >> return '\\'+		'"':_		-> discard 1 >> return '\"'+		'\'':_		-> discard 1 >> return '\''++-- Production ascii from section B.2++		'^':c:_		-> discard 2 >> cntrl c+		'N':'U':'L':_	-> discard 3 >> return '\NUL'+		'S':'O':'H':_	-> discard 3 >> return '\SOH'+		'S':'T':'X':_	-> discard 3 >> return '\STX'+		'E':'T':'X':_	-> discard 3 >> return '\ETX'+		'E':'O':'T':_	-> discard 3 >> return '\EOT'+		'E':'N':'Q':_	-> discard 3 >> return '\ENQ'+		'A':'C':'K':_	-> discard 3 >> return '\ACK'+		'B':'E':'L':_	-> discard 3 >> return '\BEL'+		'B':'S':_	-> discard 2 >> return '\BS'+		'H':'T':_	-> discard 2 >> return '\HT'+		'L':'F':_	-> discard 2 >> return '\LF'+		'V':'T':_	-> discard 2 >> return '\VT'+		'F':'F':_	-> discard 2 >> return '\FF'+		'C':'R':_	-> discard 2 >> return '\CR'+		'S':'O':_	-> discard 2 >> return '\SO'+		'S':'I':_	-> discard 2 >> return '\SI'+		'D':'L':'E':_	-> discard 3 >> return '\DLE'+		'D':'C':'1':_	-> discard 3 >> return '\DC1'+		'D':'C':'2':_	-> discard 3 >> return '\DC2'+		'D':'C':'3':_	-> discard 3 >> return '\DC3'+		'D':'C':'4':_	-> discard 3 >> return '\DC4'+		'N':'A':'K':_	-> discard 3 >> return '\NAK'+		'S':'Y':'N':_	-> discard 3 >> return '\SYN'+		'E':'T':'B':_	-> discard 3 >> return '\ETB'+		'C':'A':'N':_	-> discard 3 >> return '\CAN'+		'E':'M':_	-> discard 2 >> return '\EM'+		'S':'U':'B':_	-> discard 3 >> return '\SUB'+		'E':'S':'C':_	-> discard 3 >> return '\ESC'+		'F':'S':_	-> discard 2 >> return '\FS'+		'G':'S':_	-> discard 2 >> return '\GS'+		'R':'S':_	-> discard 2 >> return '\RS'+		'U':'S':_	-> discard 2 >> return '\US'+		'S':'P':_	-> discard 2 >> return '\SP'+		'D':'E':'L':_	-> discard 3 >> return '\DEL'++-- Escaped numbers++		'o':c:_ | isOctDigit c -> do+					discard 1+					n <- lexOctal+					checkChar n+		'x':c:_ | isHexDigit c -> do+					discard 1+					n <- lexHexadecimal+					checkChar n+		c:_ | isDigit c -> do+					n <- lexDecimal+					checkChar n++		_		-> fail "Illegal escape sequence"++    where+	checkChar n | n <= 0x01FFFF = return (chr (fromInteger n))+	checkChar _		    = fail "Character constant out of range"++-- Production cntrl from section B.2++	cntrl :: Char -> Lex a Char+	cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))+	cntrl _                        = fail "Illegal control character"++-- assumes at least one octal digit+lexOctal :: Lex a Integer+lexOctal = do+	ds <- lexWhile isOctDigit+	return (parseInteger 8 ds)++-- assumes at least one hexadecimal digit+lexHexadecimal :: Lex a Integer+lexHexadecimal = do+	ds <- lexWhile isHexDigit+	return (parseInteger 16 ds)++-- assumes at least one decimal digit+lexDecimal :: Lex a Integer+lexDecimal = do+	ds <- lexWhile isDigit+	return (parseInteger 10 ds)++-- Stolen from Hugs's Prelude+parseInteger :: Integer -> String -> Integer+parseInteger radix ds =+	foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)++-- pragmas for which we just want the raw contents of+pragmas_raw = [["OPTIONS", "JHC_OPTIONS", "OPTIONS_JHC" ]]++-- pragmas which just have a simple string based start rule.+pragmas_std = [+    ["NOETA"],+    ["SUPERINLINE"],+    ["MULTISPECIALIZE", "MULTISPECIALISE"],+    ["SRCLOC_ANNOTATE"]+    ]++pragmas_exp = [+    ["CTYPE"]+    ]++-- pragmas with a special starting token+pragmas_parsed = [+    (["INLINE"],PragmaInline "INLINE"),+    (["NOINLINE","NOTINLINE"],PragmaInline "NOINLINE"),+    (["RULES","RULE","RULES_JHC","RULE_JHC"],PragmaRules False),+    (["CATALYST","CATALYSTS"],PragmaRules True),+    (["SPECIALIZE", "SPECIALISE"],PragmaSpecialize False),+    (["SUPERSPECIALIZE", "SUPERSPECIALISE"],PragmaSpecialize True)+    ]++pragmas = Map.fromList $ [ (y,Left x) | xs@(x:_)  <- pragmas_raw, y <- xs] +++    [ (y,Right w) | (xs@(~(x:_)),w)  <- pragmas_all , y <- xs] where+        pragmas_all = pragmas_parsed +++            [ (xs,PragmaStart x) | xs@(~(x:_)) <- pragmas_std ] +++            [ (xs,PragmaExp x) | xs@(~(x:_)) <- pragmas_exp ]++pragmas_ignored = Set.fromList ["LANGUAGE", "OPTIONS_GHC", "UNPACK"]++normPragma :: String -> Either String Token+normPragma s | ~(Just v) <- Map.lookup s pragmas  = v+toUnqualName n = toName UnknownType (Nothing :: Maybe Module,n)
+ src/FrontEnd/ParseMonad.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE NamedFieldPuns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.ParseMonad+-- Copyright   :  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Monads for the Haskell parser and lexer.+--+-----------------------------------------------------------------------------++module FrontEnd.ParseMonad(+		-- * Parsing+		P, ParseResult(..), atSrcLoc, LexContext(..),+		ParseMode(..),+                parseModeOptions,+		runParserWithMode, runParser,+		getSrcLoc, setSrcLoc, pushCurrentContext, popContext,thenP,returnP,+		-- * Lexing+		Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,+		alternative, checkBOL, setBOL, startToken, getOffside,+		pushContextL, popContextL, lexParseMode,+                pullCtxtFlag, setFlagDo+	) where++import Control.Monad+import Data.Functor+import Data.Monoid+import qualified Control.Applicative as A+import qualified Data.Set as Set++import FrontEnd.SrcLoc+import FrontEnd.Warning+import Options+import PackedString+import qualified FlagOpts as FO++-- | The result of a parse.+data ParseResult a+	= ParseOk a	-- ^ The parse succeeded, yielding a value and a set of warnings.+	| ParseFailed SrcLoc String+				-- ^ The parse failed at the specified+				-- source location, with an error message.+	deriving Show++-- internal version+data ParseStatus a = Ok ParseState a | Failed SrcLoc String+	deriving Show++data LexContext = NoLayout | Layout Int+	deriving (Eq,Ord,Show)++--type ParseState = [LexContext]+data ParseState = ParseState {+    psLexContext :: [LexContext],+    psWarnings :: [Warning],+    psInDo :: !Bool,+    psForceClose :: !Bool+    } deriving(Show)++instance Functor ParseResult where+    fmap f (ParseOk x) = ParseOk (f x)+    fmap _ (ParseFailed x y) = ParseFailed x y++instance A.Applicative ParseResult where+  pure = ParseOk+  ParseOk f <*> x = f <$> x+  ParseFailed loc msg <*> _ = ParseFailed loc msg++instance Monad ParseResult where+  return = A.pure+  ParseOk x         >>= f = f x+  ParseFailed loc msg >>= _ = ParseFailed loc msg++instance Monoid m => Monoid (ParseResult m) where+  mempty = ParseOk mempty+  ParseOk x `mappend` ParseOk y = ParseOk $ x `mappend` y+  ParseOk x `mappend` err       = err+  err       `mappend` _         = err -- left-biased++indentOfParseState :: ParseState -> Int+indentOfParseState ParseState { psLexContext = (Layout n:_) } = n+indentOfParseState _            = 0++emptyParseState = ParseState { psLexContext = [], psWarnings = [], psForceClose = False, psInDo = False }++-- | Static parameters governing a parse.+-- More to come later, e.g. literate mode, language extensions.++data ParseMode = ParseMode {+                -- | original name of the file being parsed+		parseFilename      :: FilePath,+                parseOpt           :: Opt,+                parseFFI           :: Bool,+                parseUnboxedValues :: Bool,+                parseUnboxedTuples :: Bool+		}++-- | Default parameters for a parse,+-- currently just a marker for an unknown filename.++defaultParseMode :: ParseMode+defaultParseMode = ParseMode {+		parseFilename = "<unknown>",+                parseOpt = options,+                parseFFI = False,+                parseUnboxedValues = False,+                parseUnboxedTuples = False+		}++parseModeOptions options = defaultParseMode {+    parseUnboxedTuples = FO.UnboxedTuples `Set.member` optFOptsSet options || FO.UnboxedValues `Set.member` optFOptsSet options,+    parseUnboxedValues = FO.UnboxedValues `Set.member` optFOptsSet options,+    parseFFI = FO.Ffi `Set.member` optFOptsSet options,+    parseOpt = options+    }++-- | Monad for parsing++newtype P a = P { runP ::+		        String		-- input string+		     -> Int		-- current column+		     -> Int		-- current line+		     -> SrcLoc		-- location of last token read+		     -> ParseState	-- layout info.+		     -> ParseMode	-- parse parameters+		     -> ParseStatus a+		}++runParserWithMode :: ParseMode -> P a -> String -> ([Warning],ParseResult a)+runParserWithMode mode (P m) s = case m s 0 1 start emptyParseState mode of+	Ok s a -> (psWarnings s,ParseOk a)+	Failed loc msg -> ([],ParseFailed loc msg)+    where start = SrcLoc {+		srcLocFileName = packString $ parseFilename mode,+		srcLocLine = 1,+		srcLocColumn = 1+	}++runParser :: P a -> String -> ([Warning],ParseResult a)+runParser = runParserWithMode defaultParseMode++instance Monad P where+	return a = P $ \_i _x _y _l s _m -> Ok s a+	P m >>= k = P $ \i x y l s mode ->+		case m i x y l s mode of+		    Failed loc msg -> Failed loc msg+		    Ok s' a -> runP (k a) i x y l s' mode+	fail s = P $ \_r _col _line loc _stk _m -> Failed loc s++returnP :: a -> P a+returnP = return+thenP :: P a -> (a -> P b) -> P b+thenP = (>>=)++atSrcLoc :: P a -> SrcLoc -> P a+P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc++--getSrcLoc :: P SrcLoc++instance MonadSrcLoc P where+    getSrcLoc = P $ \_i _x _y l s _m -> Ok s l++instance MonadWarn P where+    addWarning w = P $ \_i _x _y _l s _m -> Ok s { psWarnings = w:psWarnings s } ()++-- Enter a new layout context.  If we are already in a layout context,+-- ensure that the new indent is greater than the indent of that context.+-- (So if the source loc is not to the right of the current indent, an+-- empty list {} will be inserted.)++pushCurrentContext :: P ()+pushCurrentContext = do+	lc <- getSrcLoc+	indent <- currentIndent+        let loc = srcLocColumn lc+        dob <- pullDoStatus+        when (if dob then loc < indent else loc <= indent) pushCtxtFlag+	pushContext (Layout loc)++currentIndent :: P Int+currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk)++pushContext :: LexContext -> P ()+pushContext ctxt =+--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $+	P $ \_i _x _y _l s _m -> Ok s { psLexContext = ctxt:psLexContext s } ()++popContext :: P ()+popContext = P $ \_i _x _y _l stk _m ->+      case psLexContext stk of+   	(_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $+            Ok stk { psLexContext = s } ()+        []    -> error "Internal error: empty context in popContext"++pullCtxtFlag :: Lex a Bool+pullCtxtFlag = Lex $ \cont -> P $ \r x y loc s ->+        runP (cont $ psForceClose s) r x y loc s { psForceClose = False }++pushCtxtFlag :: P ()+pushCtxtFlag =+    P $ \_i _x _y _l s _m -> case psForceClose s of+        False -> Ok s { psForceClose = True } ()+        _     -> error "Internal error: context flag already pushed"++pullDoStatus :: P Bool+pullDoStatus = P $ \_i _x _y _l s _m -> Ok s { psInDo = False } (psInDo s)++setFlagDo :: Lex a ()+setFlagDo = Lex $ \cont -> P $ \r x y loc s ->+        runP (cont ()) r x y loc s { psInDo = True }++-- Monad for lexical analysis:+-- a continuation-passing version of the parsing monad+--+newtype Lex r a = Lex { runL :: (a -> P r) -> P r }++instance Monad (Lex r) where+	return a = Lex $ \k -> k a+	Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)+	Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)+	fail s = Lex $ \_ -> fail s++instance MonadWarn (Lex r) where+    addWarning w = Lex $ \k -> addWarning w >> k ()+instance MonadSrcLoc (Lex r) where+    getSrcLoc = Lex $ \k -> getSrcLoc >>= k++-- Operations on this monad++getInput :: Lex r String+getInput = Lex $ \cont -> P $ \r -> runP (cont r) r++-- | Discard some input characters (these must not include tabs or newlines).++discard :: Int -> Lex r ()+discard n = Lex $ \cont -> P $ \r x -> runP (cont ()) (drop n r) (x+n)++setSrcLoc :: SrcLoc -> Lex a ()+setSrcLoc srcloc = Lex $ \cont -> P $ \r x l _ -> runP (cont ()) r x l srcloc++-- | Discard the next character, which must be a newline.++lexNewline :: Lex a ()+lexNewline = Lex $ \cont -> P $ \(_:r) _x y loc -> runP (cont ()) r 1 (y+1) loc { srcLocLine = srcLocLine loc + 1 }++-- | Discard the next character, which must be a tab.++lexTab :: Lex a ()+lexTab = Lex $ \cont -> P $ \(_:r) x -> runP (cont ()) r (nextTab x)++nextTab :: Int -> Int+nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)++tAB_LENGTH :: Int+tAB_LENGTH = 8++lexParseMode :: Lex a ParseMode+lexParseMode = Lex $ \cont -> P $ \r x y z s m -> runP (cont m) r x y z s m++-- Consume and return the largest string of characters satisfying p++lexWhile :: (Char -> Bool) -> Lex a String+lexWhile p = Lex $ \cont -> P $ \r x ->+	let (cs,rest) = span p r in+	runP (cont cs) rest (x + length cs)++-- An alternative scan, to which we can return if subsequent scanning+-- is unsuccessful.++alternative :: Lex a v -> Lex a (Lex a v)+alternative (Lex v) = Lex $ \cont -> P $ \r x y ->+	runP (cont (Lex $ \cont' -> P $ \_r _x _y ->+		runP (v cont') r x y)) r x y++-- The source location is the coordinates of the previous token,+-- or, while scanning a token, the start of the current token.++-- col is the current column in the source file.+-- We also need to remember between scanning tokens whether we are+-- somewhere at the beginning of the line before the first token.+-- This could be done with an extra Bool argument to the P monad,+-- but as a hack we use a col value of 0 to indicate this situation.++-- Setting col to 0 is used in two places: just after emitting a virtual+-- close brace due to layout, so that next time through we check whether+-- we also need to emit a semi-colon, and at the beginning of the file,+-- by runParser, to kick off the lexer.+-- Thus when col is zero, the true column can be taken from the loc.++checkBOL :: Lex a Bool+checkBOL = Lex $ \cont -> P $ \r x y loc ->+		if x == 0 then runP (cont True) r (srcLocColumn loc) y loc+			else runP (cont False) r x y loc++setBOL :: Lex a ()+setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0++-- Set the loc to the current position++startToken :: Lex a ()+startToken = Lex $ \cont -> P $ \s x y oloc stk mode ->+	let loc = oloc { srcLocColumn = x } in+	runP (cont ()) s x y loc stk mode++-- Current status with respect to the offside (layout) rule:+-- LT: we are to the left of the current indent (if any)+-- EQ: we are at the current indent (if any)+-- GT: we are to the right of the current indent, or not subject to layout++getOffside :: Lex a Ordering+getOffside = Lex $ \cont -> P $ \r x y loc stk ->+		runP (cont (compare x (indentOfParseState stk))) r x y loc stk++pushContextL :: LexContext -> Lex a ()+pushContextL ctxt = Lex $ \cont -> P $ \r x y loc stk ->+		runP (cont ()) r x y loc stk { psLexContext = ctxt:psLexContext stk }++popContextL :: String -> Lex a ()+popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case psLexContext stk of+		(_:ctxt) -> runP (cont ()) r x y loc stk { psLexContext = ctxt }+		[]       -> error ("Internal error: empty context in " ++ fn)++{-+-- ---------------------------------------------------------------------------+-- Construct a parse error++srcParseErr+  :: String       -- current buffer (placed just after the last token)+  -> Int                -- length of the previous token+  -> Message+srcParseErr buf len+  = hcat [ if null token+         then ptext SLIT("parse error (possibly incorrect indentation)")+         else hcat [ptext SLIT("parse error on input "),+                char '`', text token, char '\'']+    ]+  where token = lexemeToString (stepOnBy (-len) buf) len++-- Report a parse failure, giving the span of the previous token as+-- the location of the error.  This is the entry point for errors+-- detected during parsing.+srcParseFail :: P a+srcParseFail = P $ \buf _ _ last_loc _ _ ->+    Failed last_loc (srcParseErr buf len)++-- A lexical error is reported at a particular position in the source file,+-- not over a token range.  TODO: this is slightly wrong, because we record+-- the error at the character position following the one which caused the+-- error.  We should somehow back up by one character.+--lexError :: String -> P a+--lexError str = do+--  loc <- getSrcLoc+--  i@(end,_) <- getInput+--  failLocMsgP loc end str++-}
+ src/FrontEnd/ParseUtils.hs view
@@ -0,0 +1,476 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.ParseUtils+-- Copyright   :  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Utilities for the Haskell parser.+--+-----------------------------------------------------------------------------++module FrontEnd.ParseUtils (+	  splitTyConApp		-- HsType -> P (Name,[HsType])+	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp+	, checkPrec		-- Integer -> P Int+	, checkContext		-- HsType -> P HsContext+	, checkDataHeader	-- HsQualType -> P (HsContext,Name,[Name])+	, checkPattern		-- HsExp -> P HsPat+	, checkPatterns+	, checkExpr		-- HsExp -> P HsExp+	, checkValDef		-- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl+	, checkUnQual		-- Name -> P Name+        , readInteger+        , readRational+        , fixupHsDecls+        , parseError+        , parseExport+        , qualTypeToClassHead+        , doForeign+        , doForeignEq+ ) where++import Data.Char+import Data.Maybe+import Data.Monoid+import Data.Ratio+import qualified Data.Set as Set+import qualified Data.Traversable as T++import C.FFI+import FrontEnd.HsSyn+import FrontEnd.ParseMonad+import FrontEnd.SrcLoc+import Name.Name+import Name.Names+import PackedString++parseError :: String -> P a+parseError = fail++splitTyConApp :: HsType -> P (Name,[HsType])+splitTyConApp t0 = split t0 []+ where+	split :: HsType -> [HsType] -> P (Name,[HsType])+	split (HsTyApp t u) ts = split t (u:ts)+	split (HsTyCon t) ts = return (t,ts)+	split _ _ = fail "Illegal data/newtype declaration"+--	split a b = fail $ "Illegal data/newtype declaration: " ++ show (a,b)++-----------------------------------------------------------------------------+-- Various Syntactic Checks++qualTypeToClassHead :: HsQualType -> P HsClassHead+qualTypeToClassHead qt = do+    let fromHsTypeApp t = f t [] where+            f (HsTyApp a b) rs = f a (b:rs)+            f t rs = (t,rs)+    case fromHsTypeApp $ hsQualTypeType qt of+        (HsTyCon className,as) -> return HsClassHead { hsClassHeadContext = hsQualTypeContext qt, hsClassHead = className, hsClassHeadArgs = as }+        _ -> fail "Invalid Class Head"++checkContext :: HsType -> P HsContext+checkContext (HsTyCon (toName TypeConstructor -> name)) | name == tc_Unit = return []+checkContext (HsTyTuple ts) =+	mapM checkAssertion ts+checkContext t = do+	c <- checkAssertion t+	return [c]++-- Changed for multi-parameter type classes++checkAssertion :: HsType -> P HsAsst+checkAssertion t =  checkAssertion' [] t+	where	checkAssertion' ts (HsTyCon c) =  tast (c,ts)+		checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a+		checkAssertion' _ _ = fail "Illegal class assertion"+                tast (a,[HsTyVar n]) = return (HsAsst a [n]) -- (a,n)+                tast _ = fail "Invalid Class. multiparameter classes not yet supported"+--checkAssertion = checkAssertion' []+--	where	checkAssertion' ts (HsTyCon c) = return (c,ts)+--		checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a+--		checkAssertion' _ _ = fail "Illegal class assertion"++checkPatterns :: [HsExp] -> P [HsPat]+checkPatterns es = mapM checkPattern es++checkDataHeader :: HsQualType -> P (HsContext,Name,[Name])+checkDataHeader (HsQualType cs t) = do+	(c,ts) <- checkSimple "data/newtype" t []+	return (cs,c,ts)++checkSimple :: String -> HsType -> [Name] -> P ((Name,[Name]))+checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)+checkSimple _kw (HsTyCon t)   xs = return (t,xs)+checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration")+--checkSimple kw t ts = fail ("Illegal " ++ kw ++ " declaration: " ++ show (t,ts))++{-+checkInstHeader :: HsQualType -> P (HsContext,Name,[HsType])+checkInstHeader (HsQualType cs t) = do+	(c,ts) <- checkInsts t []+	return (cs,c,ts)++checkInsts :: HsType -> [HsType] -> P ((Name,[HsType]))+checkInsts (HsTyApp l t) ts = checkInsts l (t:ts)+checkInsts (HsTyCon c)   ts = return (c,ts)+checkInsts _ _ = fail "Illegal instance declaration"+-}++-----------------------------------------------------------------------------+-- Checking Patterns.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: HsExp -> P HsPat+checkPattern e = checkPat e []++checkPat :: HsExp -> [HsPat] -> P HsPat+checkPat (HsCon c) args = return (HsPApp c args)+checkPat (HsApp f x) args = do+	x <- checkPat x []+	checkPat f (x:args)+checkPat e [] = case e of+	HsVar x   -> return (HsPVar x)+	HsLit l            -> return (HsPLit l)+	HsInfixApp l op r  -> do+			      l <- checkPat l []+			      r <- checkPat r []+			      case op of+				 HsCon c -> return (HsPInfixApp l c r)+				 _ -> patFail+	HsTuple es         -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPTuple ps)+	HsUnboxedTuple es  -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPUnboxedTuple ps)+	HsList es	   -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPList ps)+	HsParen e	   -> do+			      p <- checkPat e []+			      return (HsPParen p)+	HsAsPat n e	   -> do+			      p <- checkPat e []+			      return (HsPAsPat n p)+	HsWildCard _	   -> return HsPWildCard+	HsIrrPat e         -> do+			      p <- T.mapM checkPattern e+			      return (HsPIrrPat p)+	HsBangPat e         -> do+			      p <- T.mapM checkPattern e+			      return (HsPBangPat p)+	HsRecConstr c fs   -> do+			      fs <- mapM checkPatField fs+			      return (HsPRec c fs)+	HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))+        HsExpTypeSig sl e t -> do+            p <- checkPat e []+            return (HsPTypeSig sl p t)+	_ -> patFail++checkPat _ _ = patFail++checkPatField :: HsFieldUpdate -> P HsPatField+checkPatField (HsFieldUpdate n e) = do+	p <- checkPat e []+	return (HsPFieldPat n p)++patFail :: P a+patFail = fail "Parse error in pattern"++-----------------------------------------------------------------------------+-- Check Expression Syntax++checkExpr :: HsExp -> P HsExp+checkExpr e = case e of+	HsVar _			  -> return e+	HsCon _			  -> return e+	HsLit _			  -> return e+	HsInfixApp e1 op e2	  -> check2Exprs e1 e2 (flip HsInfixApp op)+	HsApp e1 e2		  -> check2Exprs e1 e2 HsApp+	HsNegApp e		  -> check1Expr e HsNegApp+	HsLambda loc ps e	  -> check1Expr e (HsLambda loc ps)+	HsLet bs e		  -> check1Expr e (HsLet bs)+	HsIf e1 e2 e3		  -> check3Exprs e1 e2 e3 HsIf+	HsCase e alts		  -> do+				     alts <- mapM checkAlt alts+				     e <- checkExpr e+				     return (HsCase e alts)+	HsDo stmts		  -> do+				     stmts <- mapM checkStmt stmts+				     return (HsDo stmts)+	HsTuple es		  -> checkManyExprs es HsTuple+	HsUnboxedTuple es	  -> checkManyExprs es HsUnboxedTuple+	HsList es		  -> checkManyExprs es HsList+	HsParen e		  -> check1Expr e HsParen+	HsLeftSection e op	  -> check1Expr e (flip HsLeftSection op)+	HsRightSection op e	  -> check1Expr e (HsRightSection op)+	HsRecConstr c fields	  -> do+				     fields <- mapM checkField fields+				     return (HsRecConstr c fields)+	HsRecUpdate e fields	  -> do+				     fields <- mapM checkField fields+				     e <- checkExpr e+				     return (HsRecUpdate e fields)+	HsEnumFrom e		  -> check1Expr e HsEnumFrom+	HsEnumFromTo e1 e2	  -> check2Exprs e1 e2 HsEnumFromTo+	HsEnumFromThen e1 e2      -> check2Exprs e1 e2 HsEnumFromThen+	HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo+	HsListComp e stmts        -> do+				     stmts <- mapM checkStmt stmts+				     e <- checkExpr e+				     return (HsListComp e stmts)+	HsExpTypeSig loc e ty     -> do+				     e <- checkExpr e+				     return (HsExpTypeSig loc e ty)+        HsAsPat _ _     -> fail "@ only valid in pattern"+        HsWildCard sl   -> return $ HsWildCard sl -- TODO check for strict mode+        HsIrrPat _      -> fail "~ only valid in pattern"+	_                         -> fail "Parse error in expression"++-- type signature for polymorphic recursion!!+check1Expr :: HsExp -> (HsExp -> a) -> P a+check1Expr e1 f = do+	e1 <- checkExpr e1+	return (f e1)++check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a+check2Exprs e1 e2 f = do+	e1 <- checkExpr e1+	e2 <- checkExpr e2+	return (f e1 e2)++check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a+check3Exprs e1 e2 e3 f = do+	e1 <- checkExpr e1+	e2 <- checkExpr e2+	e3 <- checkExpr e3+	return (f e1 e2 e3)++checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a+checkManyExprs es f = do+	es <- mapM checkExpr es+	return (f es)++checkAlt :: HsAlt -> P HsAlt+checkAlt (HsAlt loc p galts bs) = do+	galts <- checkGAlts galts+	return (HsAlt loc p galts bs)++checkGAlts :: HsRhs -> P HsRhs+checkGAlts (HsUnGuardedRhs e) = check1Expr e HsUnGuardedRhs+checkGAlts (HsGuardedRhss galts) = do+	galts <- mapM checkGAlt galts+	return (HsGuardedRhss galts)++checkGAlt :: HsGuardedRhs -> P HsGuardedRhs+checkGAlt (HsGuardedRhs loc e1 e2) = check2Exprs e1 e2 (HsGuardedRhs loc)++checkStmt :: HsStmt -> P HsStmt+checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p)+checkStmt (HsQualifier e) = check1Expr e HsQualifier+checkStmt s@(HsLetStmt _) = return s++checkField :: HsFieldUpdate -> P HsFieldUpdate+checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)++-----------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl+checkValDef srcloc lhs rhs whereBinds =+    case isFunLhs lhs [] of+	 Just (f,es) -> do+			ps <- mapM checkPattern es+			return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])+         Nothing     -> do+			lhs <- checkPattern lhs+			return (HsPatBind srcloc lhs rhs whereBinds)++-- A variable binding is parsed as an HsPatBind.++isFunLhs :: HsExp -> [HsExp] -> Maybe (Name, [HsExp])+isFunLhs (HsInfixApp l (HsVar ( op)) r) es = Just (op, l:r:es)+isFunLhs (HsApp (HsVar ( f)) e) es = Just (f, e:es)+isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)+isFunLhs (HsApp f e) es = isFunLhs f (e:es)+isFunLhs _ _ = Nothing++-----------------------------------------------------------------------------+-- In a class or instance body, a pattern binding must be of a variable.++{-+checkClassBody :: [HsDecl] -> P [HsDecl]+checkClassBody decls = do+	mapM_ checkMethodDef decls+	return decls++checkMethodDef :: HsDecl -> P ()+checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return ()+checkMethodDef (HsPatBind loc _ _ _) =+	fail "illegal method definition" `atSrcLoc` loc+checkMethodDef _ = return ()+-}++-----------------------------------------------------------------------------+-- Check that an identifier or symbol is unqualified.+-- For occasions when doing this in the grammar would cause conflicts.++checkUnQual :: Name -> P Name+checkUnQual n = if isJust (getModule n) then fail "Illegal qualified name" else return n+--checkUnQual (Qual _ _) = fail "Illegal qualified name"+--checkUnQual n@(UnQual _) = return n+--checkUnQual (Special _) = fail "Illegal special name"++-----------------------------------------------------------------------------+-- Miscellaneous utilities++checkPrec :: Integer -> P Int+checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)+checkPrec i | otherwise	       = fail ("Illegal precedence " ++ show i)++mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp+mkRecConstrOrUpdate (HsCon c) fs       = return (HsRecConstr c fs)+mkRecConstrOrUpdate e         fs@(_:_) = return (HsRecUpdate e fs)+mkRecConstrOrUpdate _         _        = fail "Empty record update"++-----------------------------------------------------------------------------+-- Reverse a list of declarations, merging adjacent HsFunBinds of the+-- same name and checking that their arities match.++{-+checkRevDecls :: [HsDecl] -> P [HsDecl]+checkRevDecls = mergeFunBinds []+    where+	mergeFunBinds revDs [] = return revDs+	mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) =+		mergeMatches ms1 ds1+	    where+		arity = length ps+		mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds)+		    | name' == name =+			if length ps' /= arity+			then fail ("arity mismatch for '" ++ show name ++ "'")+			     `atSrcLoc` loc+			else mergeMatches (ms++ms') ds+		mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds+	mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds+-}++-- this used to be done in post-process++-- collect associated funbind equations (matches) into a single funbind+-- intended as a post-processer for the parser output+fixupHsDecls :: [HsDecl] -> [HsDecl]+fixupHsDecls (d@(HsFunBind matches):ds) =  (HsFunBind newMatches) : fixupHsDecls different where+    funName = matchName $ head matches+    (same, different) = span (sameFun funName) (d:ds)+    newMatches =  collectMatches same+fixupHsDecls (d:ds) =  d : fixupHsDecls ds+fixupHsDecls [] = []+-- get the variable name bound by a match+matchName (HsMatch _sloc name _pats _rhs _whereDecls) = name++-- True if the decl is a HsFunBind and binds the same name as the+-- first argument, False otherwise+sameFun :: Name -> HsDecl -> Bool+sameFun name (HsFunBind matches@(_:_)) = name == (matchName $ head matches)+sameFun _ _ = False++doForeign :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> m HsDecl+doForeign srcLoc names ms qt = ans where+    ans = do+        (mstring,vname@(nameParts -> (_,Nothing,cname)),names') <- case ms of+            Just (s,n) -> return (Just s,n,names)+            Nothing -> do+                (n:ns) <- return $ reverse names+                return (Nothing,n,reverse ns)+        let f ["import","primitive"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe Primitive) vname qt+            f ["import","dotnet"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe DotNet) vname qt+            f ("import":rs) cname = do+                let (safe,conv) = pconv rs+                im <- parseImport conv mstring vname+                conv <- return (if conv == CApi then CCall else conv)+                return $ HsForeignDecl srcLoc (FfiSpec im safe conv) vname qt+            f ("export":rs) cname = do+                let (safe,conv) = pconv rs+                return $ HsForeignExport srcLoc (FfiExport cname safe conv undefined undefined) vname qt+            f _ _ = error "ParseUtils: bad."+        f (map show names') (maybe cname id mstring) where+    pconv rs = g Safe CCall rs where+        g _ cc ("safe":rs) = g Safe cc rs+        g _ cc ("unsafe":rs) = g Unsafe cc rs+        g s _  ("ccall":rs)  = g s CCall rs+        g s _  ("capi":rs)  = g s CApi rs+        g s _  ("stdcall":rs) = g s StdCall rs+        g s c  [] = (s,c)+        g _ _ rs = error $ "FrontEnd.ParseUtils: unknown foreign flags " ++ show rs++doForeignEq :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> HsExp -> m HsDecl+doForeignEq srcLoc names ms qt e = undefined++-- FFI parsing++parseExport :: Monad m => String -> Name -> m String+parseExport cn hn =+    case words cn of+      [x] | isCName x -> return x+      []              -> return (show hn)+      _               -> fail ("Invalid cname in export declaration: "++show cn)++parseImport :: Monad m => CallConv -> Maybe String -> Name -> m FfiType+parseImport _ Nothing hn = return $ Import (show hn) mempty+parseImport cc (Just cn) hn =+    case words cn of+      ["dynamic"]   -> return Dynamic+      ["wrapper"]   -> return Wrapper+      []            -> return $ Import (show hn) mempty+      ("static":xs) -> parseIS cc xs+      xs            -> parseIS cc xs++parseIS cc rs = f Set.empty rs where+    f s ['&':n] | isCName n = return $ ImportAddr n $ Requires s+    f s [n]     | isCName n = return $ Import     n $ Requires s+    f s ["&",n] | isCName n = return $ ImportAddr n $ Requires s+    f s (i:r)               = f (Set.insert (cc,packString i) s) r+    f s x                   = fail ("Syntax error parsing foreign import: "++show x)++isCName []     = False+isCName (c:cs) = p1 c && all p2 cs+    where p1 c = isAlpha c    || any (c==) oa+          p2 c = isAlphaNum c || any (c==) oa+          oa   = "_-$"++-- collects all the HsMatch equations from any FunBinds+-- from a list of HsDecls+collectMatches :: [HsDecl] -> [HsMatch]+collectMatches [] = []+collectMatches (d:ds)+   = case d of+        (HsFunBind matches) -> matches ++ collectMatches ds+        _anythingElse             -> collectMatches ds++-- Stolen from Hugs' Prelude++readInteger :: String -> Integer+readInteger ('0':'o':ds) = readInteger2  8 isOctDigit ds+readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds+readInteger          ds  = readInteger2 10 isDigit    ds++readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer+readInteger2 radix _ ds = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds)++-- Hack...++readRational :: String -> Rational+readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0;  ('+':e2) -> read e2; _ -> read e} - length m)+  where (i,r1) = span isDigit xs+        (m,r2) = span isDigit (dropWhile (=='.') r1)+        e      = dropWhile (=='e') r2
+ src/FrontEnd/Rename.hs view
@@ -0,0 +1,881 @@+module FrontEnd.Rename(+    renameModule,+    unRename,+    collectDefsHsModule,+    FieldMap(..),+    DeNameable(..),+    renameStatement+    ) where++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.RWS+import Control.Monad.Writer+import Data.Char+import Data.Maybe+import Data.List hiding(union)+import qualified Data.Foldable as Seq+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set++import Doc.DocLike(tupled)+import DerivingDrift.Drift+import FrontEnd.Desugar (desugarHsModule,doToExp,listCompToExp)+import FrontEnd.HsSyn+import FrontEnd.SrcLoc hiding(srcLoc)+import qualified FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse+import FrontEnd.Warning+import Name.Name as Name+import Name.Names+import Options+import Support.FreeVars+import Util.Gen+import Util.Inst()+import Util.SetLike+import qualified FrontEnd.HsErrors as HsErrors+import qualified Name.VConsts as V++data FieldMap = FieldMap+    !(Map.Map Name Int)          -- a map of data constructors to their arities+    !(Map.Map Name [(Name,Int)]) -- a map of field labels to ...++instance Monoid FieldMap where+    mempty = FieldMap mempty mempty+    mappend (FieldMap a b) (FieldMap c d) =+        FieldMap (a `mappend` c) (b `mappend` d)++type SubTable = Map.Map Name Name++newtype ScopeState = ScopeState Int++data Context+    = ContextTopLevel+    | ContextInstance !Name+    | ContextLocal+    deriving(Eq)++data Env = Env {+    envModule      :: Module,+    envNameMap     :: Map.Map Name (Either String Name),+    envOptions     :: Opt,+    envFieldLabels :: FieldMap,+    envSrcLoc      :: SrcLoc+    }++addTopLevels :: HsModule -> RM a -> RM a+addTopLevels  hsmod action = do+    mod <- getCurrentModule+    let cdefs = map (\ (x,y,_) -> (x,y)) $ fst $ collectDefsHsModule hsmod+        nmap = foldl f [] (fsts cdefs)+        f r hsName@(getModule -> Just _)+            | Just _ <- V.fromTupname hsName, toModule "Jhc.Prim.Prim" == mod+                = let nn = hsName in (nn,nn):r+            | nameName tc_Arrow == hsName, toModule "Jhc.Prim.Prim" == mod+                = let nn = hsName in (nn,nn):r+            | otherwise = let nn = toUnqualified hsName in (nn,hsName):(hsName,hsName):r+        f r z = let nn = qualifyName mod z in (z,nn):(nn,nn):r+        z ns = mapM mult (filter (\x -> length x > 1) $+            groupBy (\a b -> fst a == fst b) (sort ns))+        mult xs@(~((n,sl):_)) = warn sl (MultiplyDefined n (snds xs))+            (show n ++ " is defined multiple times: " ++ show xs)+    z cdefs+    let amb k x y | x == y = x+        amb k (Right n1) (Right n2) = Left (ambig k [n1,n2])+        amb _ _ l  = l+    local (\e -> e { envNameMap = Map.unionWithKey amb (Map.map Right $ Map.fromList nmap) (envNameMap e) }) action++createSelectors sloc ds = mapM g ns where+    ds' :: [(Name,[(Name,HsBangType)])]+    ds' = [ (c,[(n,t) | (ns,t) <- rs , n <- ns ]) | HsRecDecl { hsConDeclName = c, hsConDeclRecArg = rs } <- ds ]+    ns = sortGroupUnderF fst $ concatMap f ds' -- [  | (c,nts) <- ds' ]+    f (c,nts) = [ (n,(c,i,length nts)) | (n,_) <- nts | i <- [0..]]+    g (n,cs) = do+        var <- clobberedName (toName Val "_sel")+        let f (_,(c,i,l)) = HsMatch sloc n [pat c i l] (HsUnGuardedRhs (HsVar var)) []+            pat c i l = HsPApp c [ if p == i then HsPVar var else HsPWildCard | p <- [0 .. l - 1]]+            els = HsMatch sloc n [HsPWildCard] (HsUnGuardedRhs HsError { hsExpSrcLoc = sloc, hsExpString = show n, hsExpErrorType = HsErrorFieldSelect } ) []+        return $ HsFunBind (map f cs ++ [els]) where++ambig x ys = "Ambiguous Name: " ++ show x ++ "\nCould refer to: " ++ tupled (map show ys)++runRename :: MonadWarn m => (a -> RM b) -> Opt -> Module -> FieldMap -> [(Name,[Name])] -> a -> m (b,Map.Map Name Name)+runRename doit opt mod fls ns m = mapM_ addWarning errors >> return (renamedMod,reverseMap) where+    nameMap = fromList $ map f ns where+        f (x,[y]) = (x,Right y)+        f (x,ys)  = (x,Left $ ambig x ys)+    startState = ScopeState 1+    startEnv = Env {+        envModule      = mod,+        envNameMap     = nameMap,+        envOptions     = opt,+        envFieldLabels = fls,+        envSrcLoc      = mempty+    }+    (renamedMod, _, (reverseMap,errors)) = runRWS (unRM $ doit m) startEnv startState++{-# NOINLINE renameModule #-}+renameModule :: MonadWarn m => Opt -> FieldMap -> [(Name,[Name])] -> HsModule -> m ((HsModule,[HsDecl]),Map.Map Name Name)+renameModule opt fls ns m = runRename go opt (hsModuleName m) fls (ns ++ driftResolvedNames) m+  where go mod = do+          let renDesugared = renameDecls . desugarHsModule+          rmod <- renDesugared mod+          inst <- hsModuleDecls `fmap` renDesugared mod{hsModuleDecls = driftDerive rmod}+          return (hsModuleDecls_u (++ inst) rmod,inst)++{-# NOINLINE renameStatement #-}+renameStatement :: MonadWarn m => FieldMap -> [(Name,[Name])] ->  Module -> HsStmt -> m HsStmt+renameStatement fls ns modName stmt = fst `liftM` runRename rename options modName fls ns stmt++withSubTable :: SubTable -> RM a -> RM a+withSubTable st action = local (\e -> e { envNameMap = Map.map Right st `union` envNameMap e }) action++renameDecls :: HsModule -> RM HsModule+renameDecls mod = do+    withSrcLoc (hsModuleSrcLoc mod) $ do+    addTopLevels mod $ do+    decls' <- renameHsDecls ContextTopLevel (hsModuleDecls mod)+    mapM_ checkExportSpec $ fromMaybe [] (hsModuleExports mod)+    return mod { hsModuleDecls = decls' }++checkExportSpec :: HsExportSpec -> RM ()+checkExportSpec e = f [DataConstructor, TypeConstructor, ClassName] e where+    f _ (HsEVar n) = do check [Val] n+    f dt (HsEAbs n) = do check dt n+    f dt (HsEThingAll n) = do check dt n+    f dt (HsEThingWith n ns) = do+        check dt n+        mapM_ (check [DataConstructor,Val]) ns+    f _ HsEModuleContents {} = return ()+    f _ (HsEQualified nt he) = f [nt] he+    check ts n = do+        nm <- asks envNameMap+        let idef = any isJust (map (flip mlookup nm) $ zipWith toName ts (repeat n))+        unless idef $ do+            sl <- getSrcLoc+            warn sl (UndefinedName n) ("unknown name in export list: " ++ show n)++expandTypeSigs :: [HsDecl] -> [HsDecl]+expandTypeSigs ds =  (concatMap f ds) where+    f (HsTypeSig sl ns qt) =  [ HsTypeSig sl [n] qt | n <- ns]+    f d = return d++getTypeClassModule :: HsClassHead -> Maybe Module+getTypeClassModule typ = getModule (hsClassHead typ)++qualifyMethodName :: Module -> Name -> Name+qualifyMethodName mod name = quoteName . toName Val $ qualifyName mod name++qualifyInstMethod :: Maybe Module -> HsDecl -> RM HsDecl+qualifyInstMethod Nothing decl = rename decl+qualifyInstMethod (Just moduleName) decl = case decl of+    HsPatBind srcLoc HsPVar {hsPatName = name} rhs decls ->+        rename $ HsPatBind srcLoc (HsPVar {hsPatName = qualifyMethodName moduleName name}) rhs decls+    HsFunBind matches -> rename $ HsFunBind (map f matches) where+        f m@HsMatch { hsMatchName } = m { hsMatchName = qualifyMethodName moduleName hsMatchName }+    _ -> rename decl++renameHsDecls :: Context -> [HsDecl] -> RM [HsDecl]+renameHsDecls c ds = f ds where+    f (d:ds) = do+        d' <- rename d+        when (c == ContextTopLevel) $ HsErrors.hsDeclTopLevel d'+        eds <- g d'+        ds' <- f ds+        return $ d':eds ++ ds'+    f [] = return []+    g HsDataDecl { hsDeclSrcLoc = sloc, hsDeclCons = cs } = createSelectors sloc cs+    g _ = return []++instance Rename HsDecl where+    rename d = withSrcLoc (FrontEnd.SrcLoc.srcLoc d) $ renameHsDecl d++renameHsDecl d = f d where+    f (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = do+        hsPat'    <- rename hsPat+        updateWithN Val hsDecls $ do+        hsDecls'  <- rename hsDecls+        hsRhs'    <- rename hsRhs+        return (HsPatBind srcLoc hsPat' hsRhs' {-where-} hsDecls')+    f (HsForeignExport a b n t) = do+        n <- renameValName n+        updateWith t $ do+            t <- rename t+            return (HsForeignExport a b n t)+    f (HsForeignDecl a b n t) = do+        n <- renameValName n+        updateWith t $ do+        t <- rename t+        return (HsForeignDecl a b n t)+    f (HsFunBind hsMatches) = do+        hsMatches' <- rename hsMatches+        return (HsFunBind hsMatches')+    f (HsTypeSig srcLoc hsNames hsQualType) = do+        hsNames' <- mapM renameValName hsNames+        updateWith hsQualType $ do+            hsQualType' <- rename hsQualType+            return (HsTypeSig srcLoc hsNames' hsQualType')+    f HsDataDecl { .. } | hsDeclDeclType == DeclTypeKind = do+        hsDeclName <- renameKindName hsDeclName+        unless (null hsDeclArgs) $+            addWarn InvalidDecl "kind declarations can't have arguments."+        when (any isHsRecDecl hsDeclCons) $+            addWarn InvalidDecl "kind declarations can't have records."+        hsDeclCons <- mapM renameKindHsCon hsDeclCons+        unless (null hsDeclDerives) $+            addWarn InvalidDecl "kind declarations can't derive classes"+        unless (null hsDeclContext) $+            addWarn InvalidDecl "kind declarations can't have context"+        return HsDataDecl { .. }+    f HsDataDecl { .. } = do+        hsDeclName <- renameTypeName hsDeclName+        updateWith (map fromTypishHsName hsDeclArgs) $ do+            hsDeclContext <- rename hsDeclContext+            hsDeclArgs <- mapM renameTypeName hsDeclArgs+            hsDeclCons <- rename hsDeclCons+            hsDeclDerives <- mapM (renameName . toName ClassName) hsDeclDerives+            return HsDataDecl { .. }+    f (HsTypeDecl srcLoc name hsNames t) = do+        hsName' <- renameTypeName name+        updateWith (Set.toList $ freeVars hsNames :: [Name]) $ do+            hsNames' <- rename hsNames+            t' <- rename t+            return (HsTypeDecl srcLoc  hsName' hsNames' t')+    f HsTypeFamilyDecl { .. } = do+        hsDeclCName <- renameTypeName hsDeclName+        updateWith (Set.toList $ freeVars hsDeclTArgs :: [Name]) $ do+            hsDeclTArgs <- rename hsDeclTArgs+            return HsTypeFamilyDecl { .. }+    f (HsClassDecl srcLoc classHead hsDecls) = do+        classHead' <- updateWithN TypeVal (hsClassHeadArgs classHead) $ rename classHead+        hsDecls' <- rename hsDecls+        return (HsClassDecl srcLoc classHead' hsDecls')+    f (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = do+        name' <- renameTypeName name+        updateWith args $ do+        args' <- mapM rename args+        hsContext' <- rename hsContext+        hsClasses' <- rename hsClasses+        hsDecls' <- rename hsDecls+        return (HsClassAliasDecl srcLoc name' args' hsContext' hsClasses' hsDecls')+    f (HsInstDecl srcLoc classHead hsDecls) = do+        updateWithN TypeVal (hsClassHeadArgs classHead) $ do+        classHead' <- rename classHead+        hsDecls' <- mapM (qualifyInstMethod (getTypeClassModule classHead')) hsDecls+        return (HsInstDecl srcLoc classHead' hsDecls')+    f (HsInfixDecl srcLoc assoc int hsNames) = do+        hsNames' <- mapM renameValName hsNames+        return $ HsInfixDecl srcLoc assoc int hsNames'+    f (HsActionDecl srcLoc pat e) = do+        pat <- rename pat+        e <- rename e+        return (HsActionDecl srcLoc pat e)+    f (HsPragmaProps srcLoc prop hsNames) = do+        hsNames' <- mapM renameValName hsNames+        return (HsPragmaProps  srcLoc prop hsNames')+    f (HsPragmaRules rs) = do+        rs' <- rename rs+        return $ HsPragmaRules rs'+    f prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } = do+        n <- if n == nameName u_instance then return n else renameValName n+        let ns = snub (getNames t)+        updateWith t $ do+            ns' <- mapM renameTypeName ns+            t <- rename t+            m <- getCurrentModule+            i <- newUniq+            let _nt = if null ns' then t else HsTyForall bs (HsQualType [] t)+                bs = [ hsTyVarBind { hsTyVarBindName = n } | n <- ns']+            return prules { hsDeclUniq = (m,i), hsDeclName = n, hsDeclType = t }+    f (HsDefaultDecl sl e) = HsDefaultDecl sl <$> rename e+    f (HsDeclDeriving sl ch) = HsDeclDeriving sl <$> rename ch+    f h = error $ "renameerr: " ++ show h++instance Rename HsClassHead where+    rename (HsClassHead cx n ts) = do+        updateWith ts $ HsClassHead <$> rename cx <*> renameName (toName ClassName n) <*> rename ts++instance Rename HsRule where+    rename prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } = do+        withSrcLoc srcLoc $ do+        updateWith (map fromValishHsName $ fsts fvs) $ do+        subTable'' <- getUpdates (catMaybes $ snds fvs)+        fvs' <- sequence [ liftM2 (,) (renameValName x) (withSubTable subTable'' $ rename y)| (x,y) <- fvs]+        e1' <- rename e1+        e2' <- rename e2+        m <- getCurrentModule+        i <- newUniq+        return prules {  hsRuleUniq = (m,i), hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }++instance Rename HsQualType where+    rename (HsQualType hsContext hsType) =+        HsQualType <$> rename hsContext <*> rename hsType++instance Rename HsAsst where+    rename (HsAsst hsName1 hsName2s) = do+        hsName1' <- renameName (toName ClassName hsName1)+        hsName2s' <- mapM renameTypeName hsName2s+        return (HsAsst hsName1' hsName2s')+    rename (HsAsstEq t1 t2) = HsAsstEq <$> rename t1 <*> rename t2++instance Rename HsConDecl where+    --rename cd@(HsConDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclConArg = hsBangTypes }) = do+    rename cd@(HsConDecl {  hsConDeclName = hsName, hsConDeclConArg = hsBangTypes, .. }) = do+        withSrcLoc hsConDeclSrcLoc $ do+        hsName' <- renameValName hsName+        updateWith  (map (toName TypeVal . hsTyVarBindName) hsConDeclExists) $ do+        hsConDeclExists <- rename hsConDeclExists+        hsBangTypes' <- rename hsBangTypes+        return cd { hsConDeclName = hsName', hsConDeclConArg = hsBangTypes', hsConDeclExists }+    rename cd@HsRecDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclRecArg = stuff} = do+        withSrcLoc srcLoc $ do+        hsName' <- renameValName hsName+        updateWith (map (toName TypeVal . hsTyVarBindName) (hsConDeclExists cd)) $ do+        es <- rename (hsConDeclExists cd)+        stuff' <- sequence [ do ns' <- mapM renameName (map (toName FieldLabel) ns); t' <- rename t; return (ns',t')  |  (ns,t) <- stuff]+        return cd { hsConDeclName = hsName', hsConDeclRecArg = stuff', hsConDeclExists = es }++renameKindHsCon HsConDecl { .. } = do+    withSrcLoc hsConDeclSrcLoc $ do+    hsConDeclName <- renameTypeName hsConDeclName+    unless (null hsConDeclExists) $+        addWarn InvalidDecl "kind declarations cannot have existential types"+    let bt e@HsBangedTy {} = do+            addWarn InvalidDecl "strictness annotations not relevant to kind declarations"+            return e+        bt (HsUnBangedTy e) = HsUnBangedTy `liftM` f e+        f (HsTyCon n) = HsTyCon `liftM` renameKindName n+        f e = addWarn InvalidDecl "invalid argument in kind declaration" >> return e+    hsConDeclConArg <- mapM bt hsConDeclConArg+    return HsConDecl { .. }+renameKindHsCon _ = error "Rename.renameKindHsCon: bad."++instance Rename HsBangType where+    rename (HsBangedTy t) = HsBangedTy `fmap` rename t+    rename (HsUnBangedTy t) = HsUnBangedTy `fmap` rename t++instance Rename HsType where+    rename t = do+        t <- renameHsType' True t+        HsErrors.hsType t+        return t++renameHsType' dovar t = pp (rt t) where+    rt :: HsType -> RM HsType+    rt (HsTyVar hsName) | dovar = do+        hsName' <- renameTypeName hsName+        return (HsTyVar hsName')+    rt v@HsTyVar {} = return v+    rt (HsTyCon hsName) = do+        hsName' <- renameTypeName hsName+        return (HsTyCon hsName')+    rt (HsTyForall ts v) = do+        updateWith (map (toName TypeVal) $ map hsTyVarBindName ts)  $ do+        ts' <- rename ts+        v' <- rename v+        return $ HsTyForall ts' v'+    rt (HsTyExists ts v) = do+        updateWith (map (toName TypeVal) $ map hsTyVarBindName ts) $ do+        ts' <- rename ts+        v' <- rename v+        return $ HsTyExists ts' v'+    rt ty = traverseHsType (renameHsType' dovar) ty+    pp t | not dovar = t+    pp t = t++class Rename a where+    rename :: a -> RM a+    rename x = return x++instance Rename x => Rename (Located x) where+    rename (Located sl x) = Located sl `fmap` rename x++instance Rename SrcLoc where++instance Rename a => Rename [a] where+    rename xs = mapM rename xs++instance (Rename a,Rename b) => Rename (a,b) where+    rename (a,b) = (,) <$> rename a <*> rename b++instance Rename a => Rename (Maybe a) where+    rename Nothing = return Nothing+    rename (Just x) = Just <$> rename x++instance Rename HsTyVarBind where+    rename tvb@HsTyVarBind { hsTyVarBindName = n } = do+        n' <- renameTypeName n+        return tvb { hsTyVarBindName = n' }++-- note that for renameHsMatch, the 'wheres' dominate the 'pats'++instance Rename HsMatch where+    rename (HsMatch srcLoc hsName hsPats hsRhs {-where-} hsDecls) = do+        withSrcLoc srcLoc $ do+        hsName' <- renameValName hsName+        updateWithN Val hsPats  $ do+        hsPats' <- rename hsPats+        updateWithN Val hsDecls $ do+        hsDecls' <- rename (expandTypeSigs hsDecls)+        mapM_ HsErrors.hsDeclLocal hsDecls'+        hsRhs' <- rename hsRhs+        return (HsMatch srcLoc hsName' hsPats' hsRhs' {-where-} hsDecls')++instance Rename HsPat where+    rename (HsPVar hsName) = HsPVar `fmap` renameValName hsName+    rename (HsPInfixApp hsPat1 hsName hsPat2) = HsPInfixApp <$> rename hsPat1 <*> renameValName hsName <*> rename hsPat2+    rename (HsPApp hsName hsPats) = HsPApp <$> renameValName hsName <*> rename hsPats+    rename (HsPRec hsName hsPatFields) = do+        hsName' <- renameValName hsName+        hsPatFields' <- rename hsPatFields+        fls <- asks envFieldLabels+        buildRecPat fls hsName' hsPatFields'+    rename (HsPAsPat hsName hsPat) = HsPAsPat <$> renameValName hsName <*> rename hsPat+    rename (HsPTypeSig sl hsPat qt)  = HsPTypeSig sl <$> rename hsPat <*> rename qt+    rename p = traverseHsPat rename p++buildRecPat :: FieldMap -> Name -> [HsPatField] -> RM HsPat+buildRecPat (FieldMap amp fls) n us = case mlookup (toName DataConstructor n) amp of+    Nothing -> failRename $ "Unknown Constructor: " ++ show n+    Just t -> do+        let f (HsPFieldPat x p) = case  mlookup (toName FieldLabel x) fls of+                Nothing -> failRename $ "Field Label does not exist: " ++ show x+                Just cs -> case lookup n [ (nameName x,(y)) | (x,y) <- cs ] of+                    Nothing -> failRename $ "Field Label does not belong to constructor: " ++ show (x,n)+                    Just i -> return (i,HsPParen p)+        fm <- mapM f us+        let g i | Just e <- lookup i fm = return e+                | otherwise = do+                    v <- newVar+                    return $ HsPVar v+        rs <- mapM g [0 .. t - 1 ]+        return $ HsPApp n rs++instance Rename HsPatField where+    rename (HsPFieldPat hsName hsPat) = do+        --gt <- gets globalSubTable      -- field names are not shadowed by local definitions.+        hsName' <- renameName (toName FieldLabel hsName) --renameName hsName gt+        hsPat' <- rename hsPat+        return (HsPFieldPat hsName' hsPat')++instance Rename HsRhs where+    rename (HsUnGuardedRhs hsExp) = HsUnGuardedRhs <$> rename hsExp+    rename (HsGuardedRhss rs) = HsGuardedRhss <$> rename rs++instance Rename HsGuardedRhs where+    rename (HsGuardedRhs srcLoc hsExp1 hsExp2) = do+        withSrcLoc srcLoc $ do+        hsExp1' <- rename hsExp1+        hsExp2' <- rename hsExp2+        return (HsGuardedRhs srcLoc hsExp1' hsExp2')++f_fromRational = HsVar $ nameName (toUnqualified v_fromRational)++newVar = do+    unique <- newUniq+    mod <- getCurrentModule+    --let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromName hsName' -} ++ "_var@"))+    let hsName'' = toName Val (mod,show unique ++ "_var@")+    return hsName''++instance Rename HsExp where+    rename (HsVar hsName) = HsVar <$> renameValName hsName+    rename (HsCon hsName) = HsCon <$> renameValName hsName+    rename i@(HsLit HsInt {}) = do return i+    rename i@(HsLit HsFrac {}) = do+        z <- rename f_fromRational+        return $ HsParen (HsApp z i)+    rename (HsLambda srcLoc hsPats hsExp) = do+        withSrcLoc srcLoc $ do+        updateWithN Val hsPats $ do+        hsPats' <- rename hsPats+        hsExp' <- rename hsExp+        return (HsLambda srcLoc hsPats' hsExp')+    rename (HsLet hsDecls hsExp) = do+        updateWithN Val hsDecls $ do+        hsDecls' <- rename (expandTypeSigs hsDecls)+        mapM_ HsErrors.hsDeclLocal hsDecls'+        hsExp' <- rename hsExp+        return (HsLet hsDecls' hsExp')+    rename (HsCase hsExp hsAlts) = do HsCase <$> rename hsExp <*> rename hsAlts+    rename (HsDo hsStmts) = do+        (ss,()) <- renameHsStmts hsStmts (return ())+        doToExp newVar (nameName v_bind) (nameName v_bind_) (nameName v_fail) ss+    rename (HsRecConstr hsName hsFieldUpdates) = do+        hsName' <- renameValName hsName+        hsFieldUpdates' <- rename hsFieldUpdates+        fls <- asks envFieldLabels+        buildRecConstr fls hsName' (hsFieldUpdates'::[HsFieldUpdate])+    rename (HsRecUpdate hsExp hsFieldUpdates) = do+        hsExp' <- rename hsExp+        hsFieldUpdates' <- rename hsFieldUpdates+        fls <- asks envFieldLabels+        buildRecUpdate fls hsExp' hsFieldUpdates' -- HsRecConstr hsName' hsFieldUpdates')+        --return (HsRecUpdate hsExp' hsFieldUpdates')+    rename (HsEnumFrom hsExp) = rename $ desugarEnum "enumFrom" [hsExp]+    rename (HsEnumFromTo hsExp1 hsExp2) = rename $  desugarEnum "enumFromTo" [hsExp1, hsExp2]+    rename (HsEnumFromThen hsExp1 hsExp2) = rename $ desugarEnum "enumFromThen" [hsExp1, hsExp2]+    rename (HsEnumFromThenTo hsExp1 hsExp2 hsExp3) = rename $  desugarEnum "enumFromThenTo" [hsExp1, hsExp2, hsExp3]+    rename (HsListComp hsExp hsStmts) = do+        (ss,e) <- renameHsStmts hsStmts (rename hsExp)+        listCompToExp newVar e ss+    rename (HsExpTypeSig srcLoc hsExp hsQualType) = do+        hsExp' <- rename hsExp+        updateWith hsQualType $ do+            hsQualType' <- rename hsQualType+            return (HsExpTypeSig srcLoc hsExp' hsQualType')+    rename (HsAsPat hsName hsExp) = HsAsPat <$> renameValName hsName <*> rename hsExp+    rename (HsWildCard sl) = do+        withSrcLoc sl $ do+            e <- createError HsErrorUnderscore ("_")+            return e+    rename p = traverseHsExp rename p++desugarEnum s as = foldl HsApp (HsVar (toName Val s)) as++createError et s = do+    sl <- getSrcLoc+    return $ HsError { hsExpSrcLoc = sl, hsExpErrorType = et, hsExpString = (show sl ++ ": " ++ s) }++failRename s = do+    sl <- getSrcLoc+    fail (show sl ++ ": " ++ s)++buildRecConstr ::  FieldMap -> Name -> [HsFieldUpdate] -> RM HsExp+buildRecConstr (FieldMap amp fls) n us = do+    undef <- createError HsErrorUninitializedField "Uninitialized Field"+    case mlookup (toName DataConstructor n) amp of+        Nothing -> failRename $ "Unknown Constructor: " ++ show n+        Just t -> do+            let f (HsFieldUpdate x e) = case  mlookup (toName FieldLabel x) fls of+                    Nothing -> failRename $ "Field Label does not exist: " ++ show x+                    Just cs -> case lookup n [ (nameName x,(y)) | (x,y) <- cs ] of+                        Nothing -> failRename $ "Field Label does not belong to constructor: " ++ show (x,n)+                        Just i -> return (i,hsParen e)+            fm <- mapM f us+            let rs = map g [0 .. t - 1 ]+                g i | Just e <- lookup i fm = e+                    | otherwise = undef+            return $ foldl HsApp (HsCon n) rs++buildRecUpdate ::  FieldMap -> HsExp -> [HsFieldUpdate] -> RM HsExp+buildRecUpdate (FieldMap amp fls) n us = do+        sl <- getSrcLoc+        let f (HsFieldUpdate x e) = case  mlookup (toName FieldLabel x) fls of+                Nothing -> failRename $ "Field Label does not exist: " ++ show x+                Just cs -> return [ (x,(y,hsParen e)) | (x,y) <- cs ]+        fm <- liftM concat $ mapM f us+        let fm' = sortGroupUnderFG fst snd fm+        let g (c,zs) = case mlookup c amp of+                Nothing -> failRename $ "Unknown Constructor: " ++ show n+                Just t -> do+                    vars <- replicateM t newVar+                    let vars' = (map HsVar vars)+                    let c' = nameName c+                    let x = foldl HsApp (HsCon c') [ maybe v id (lookup i zs) | v <- vars' | i <- [ 0 .. t - 1] ]+                    return $ HsAlt sl (HsPApp c' (map HsPVar vars))  (HsUnGuardedRhs x) []+        as <- mapM g fm'+        pe <- createError HsErrorRecordUpdate "Record Update Error"+        return $ HsCase n (as ++ [HsAlt sl HsPWildCard (HsUnGuardedRhs pe) []])++instance Rename HsAlt where+    rename (HsAlt srcLoc hsPat hsGuardedAlts {-where-} hsDecls) = withSrcLoc srcLoc $ do+        updateWithN Val hsPat $ do+        hsPat' <- rename hsPat+        updateWithN Val hsDecls $ do+        hsDecls' <- rename (expandTypeSigs hsDecls)+        mapM_ HsErrors.hsDeclLocal hsDecls'+        hsGuardedAlts' <- rename hsGuardedAlts+        return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')++renameHsStmts :: [HsStmt] -> RM a  -> RM ([HsStmt],a)+renameHsStmts ss fe = f ss [] where+    f (HsGenerator sl p e:ss) rs = do+        e' <- rename e+        updateWith p $ do+          p' <- rename p+          f ss (HsGenerator sl p' e':rs)+    f (s:ss) rs = do+        updateWith s $ do+          s' <- rename s+          f ss (s':rs)+    f [] rs = do+        e <- fe+        return (reverse rs,e)++instance Rename HsStmt where+    rename (HsGenerator srcLoc hsPat hsExp) = do+        hsExp' <- rename hsExp+        hsPat' <- rename hsPat+        return (HsGenerator srcLoc hsPat' hsExp')+    rename (HsQualifier hsExp) = do+        hsExp' <- rename hsExp+        return (HsQualifier hsExp')+    rename (HsLetStmt hsDecls) = do+        hsDecls' <- rename (expandTypeSigs hsDecls)+        mapM_ HsErrors.hsDeclLocal hsDecls'+        return (HsLetStmt hsDecls')++instance Rename HsFieldUpdate where+    rename (HsFieldUpdate hsName hsExp) = do+--        gt <- gets globalSubTable              -- field names are global and not shadowed+ --       hsName' <- renameName hsName gt      -- TODO field names should have own namespace+        hsName' <- renameName (toName FieldLabel hsName)      -- TODO field names should have own namespace+        hsExp' <- rename hsExp+        return (HsFieldUpdate hsName' hsExp')++renameValName :: Name -> RM Name+renameValName hsName = renameName (fromValishHsName hsName)++renameTypeName :: Name -> RM Name+renameTypeName hsName = renameName (fromTypishHsName hsName)++renameKindName :: Name -> RM Name+renameKindName hsName = renameName (toName SortName hsName)++renameName :: Name -> RM Name+-- a few hard coded cases+renameName hsName+    | Just n <- fromQuotedName hsName = return n+    | hsName `elem` [tc_Arrow,dc_Unit,tc_Unit] = return hsName+    | (nt,Just m,i) <- nameParts hsName, '@':_ <- show m = return $ toName nt (m, i)+    | Just _ <- V.fromTupname hsName = return hsName+renameName hsName = do+    subTable <- asks envNameMap+    case mlookup hsName subTable of+        Just (Right name) -> do+            tell (Map.singleton name hsName,mempty)+            return name+        Just (Left err) -> do+            addWarn (UndefinedName hsName) err+            return hsName+        Nothing -> do+            let err = "Unknown name: " ++ show hsName+            addWarn (UndefinedName hsName) err+            return hsName++clobberedName :: Name -> RM Name+clobberedName hsName = do+    unique     <- newUniq+    currModule <- getCurrentModule+    return $ renameAndQualify hsName unique currModule++clobberName :: Name -> RM SubTable+clobberName hsName = do+    hsName' <- clobberedName hsName+    return $ msingleton hsName hsName'++renameAndQualify :: Name -> Int -> Module -> Name+renameAndQualify name unique currentMod = qualifyName currentMod (renameName name unique) where+    renameName n unique = mapName (id,((show unique ++ "_") ++)) n++-- | unRename gets the original identifier name from the renamed version+unRename :: Name -> Name+unRename name = mapName (id,unRenameString) name++unRenameString :: String -> String+unRenameString s@((isDigit -> False):_) = s+unRenameString s = (dropUnderscore . dropDigits) s where+    dropUnderscore ('_':rest) = rest+    dropUnderscore otherList = otherList+    dropDigits = dropWhile isDigit++updateWithN nt x action = getUpdatesN nt x >>= flip withSubTable action+getUpdatesN nt x = unions `fmap` mapM clobberName (map (toName nt) $ getNames x)++updateWith x action = getUpdates x >>= flip withSubTable action+getUpdates x = unions `fmap` mapM clobberName (getNames x)++class UpdateTable a where+    getNames :: a -> [Name]+    getNames a = []++instance UpdateTable a => UpdateTable [a] where+    getNames xs = concatMap getNames xs+instance (UpdateTable a, UpdateTable b) => UpdateTable (a,b) where+    getNames (a,b) = getNames a ++ getNames b++instance UpdateTable Name where+    getNames x | nameType x == QuotedName = []+               | otherwise = [x]++instance UpdateTable HsDecl where+    getNames hsDecl = fsts $ getNamesAndASrcLocsFromHsDecl hsDecl+instance UpdateTable HsPat where+    getNames hsPat = getNamesFromHsPat hsPat+instance UpdateTable HsStmt where+    getNames hsStmt = fsts $ getNamesAndASrcLocsFromHsStmt hsStmt+instance UpdateTable HsQualType where+    getNames (HsQualType _hsContext hsType) = getNames hsType+instance UpdateTable HsType where+    getNames t = execWriter (getNamesFromType t)  where+        getNamesFromType (HsTyVar hsName) = tell [fromTypishHsName hsName]+        getNamesFromType t = traverseHsType_ getNamesFromType t++getNamesAndASrcLocsFromHsDecl :: HsDecl -> [(Name, SrcLoc)]+getNamesAndASrcLocsFromHsDecl d = f d where+    f (HsPatBind srcLoc (HsPVar hsName) _ _) = [(fromValishHsName hsName, srcLoc)]+    f (HsPatBind sloc _ _ _) = error $ "non simple pattern binding found (sloc): " ++ show sloc+    f (HsFunBind (HsMatch { .. }:_)) = [(fromValishHsName hsMatchName,hsMatchSrcLoc)]+    f (HsForeignDecl { .. }) = [(fromValishHsName hsDeclName, hsDeclSrcLoc)]+    f _ = []++-- | Collect all names defined in a module as well as their declaration points+-- and any subnames they might have. In addition, collect the arities of any+-- constructors.++collectDefsHsModule :: HsModule -> ([(Name,SrcLoc,[Name])],[(Name,Int)])+collectDefsHsModule m = (\ (x,y) -> (Seq.toList x,Seq.toList y)) $ execWriter (mapM_ f (hsModuleDecls m)) where+    toName t n = Name.toName t (qualifyName (hsModuleName m) n)+    tellName sl n = tellF [(n,sl,[])]+    tellF xs = tell (Seq.fromList xs,Seq.empty) >> return ()+    tellS xs = tell (Seq.empty,Seq.fromList xs) >> return ()+    f (HsForeignDecl a _ n _)    = tellName a (toName Val n)+    f (HsForeignExport a e _ _)  = tellName a (ffiExportName e)+    f (HsFunBind [])  = return ()+    f (HsFunBind (HsMatch a n _ _ _:_))  = tellName a (toName Val n)+    f (HsPatBind srcLoc p _ _)  = mapM_ (tellName srcLoc) [ (toName Val n) | n <- (getNamesFromHsPat p) ]+    f (HsActionDecl srcLoc p _) = mapM_ (tellName srcLoc) [ (toName Val n) | n <- (getNamesFromHsPat p) ]+    f (HsTypeDecl sl n _ _) = tellName sl (toName TypeConstructor n)+    f HsDataDecl { hsDeclDeclType = DeclTypeKind, hsDeclSrcLoc =sl, hsDeclName = n, hsDeclCons = cs } = do+        tellF $ (toName SortName n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup cs where+            cs' = concatMap (namesHsConDeclSort' toName) cs+    f HsDataDecl { hsDeclSrcLoc =sl, hsDeclName = n, hsDeclCons = cs } = do+        tellF $ (toName TypeConstructor n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup cs where+            cs' = concatMap (namesHsConDecl' toName) cs+    f cd@(HsClassDecl sl ch ds) = tellF $ (toName ClassName $ hsClassHead ch,sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]  where+        cs = (mconcatMap (namesHsDeclTS' toName) ds)+    f cad@(HsClassAliasDecl { hsDeclSrcLoc = sl, hsDeclName = n, hsDeclDecls = ds })+           = tellF $ (toName Name.ClassName n,sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]+        where+          cs = (mconcatMap (namesHsDeclTS' toName) ds)++    f _ = return ()+    zup cs = tellS (map g cs) where+        g ca = (toName DataConstructor (hsConDeclName ca), length $ hsConDeclArgs ca)++    namesHsConDecl' toName c = ans where+        dc = (toName DataConstructor $ hsConDeclName c,sl,fls')+        sl = hsConDeclSrcLoc c+        ans = dc : [ (toName Val n,sl,[]) |  n <- fls ]  ++  [ (n,sl,[]) |  n <- fls' ]+        fls' = map (toName FieldLabel) fls+        fls = case c of+            HsRecDecl { hsConDeclRecArg = ra } -> concatMap fst ra -- (map (rtup (hsConDeclSrcLoc c). toName FieldLabel) . fst) ra+            _ -> []++    namesHsConDeclSort' toName c = [dc] where+        dc = (toName TypeConstructor $ hsConDeclName c,sl,[])+        sl = hsConDeclSrcLoc c++    namesHsDeclTS' toName (HsTypeSig sl ns _) = (map ((,sl) . toName Val) ns)+    namesHsDeclTS' toName (HsTypeDecl sl n _ _) = [(toName TypeConstructor n,sl)]+    namesHsDeclTS' _ _ = []++getNamesAndASrcLocsFromHsStmt :: HsStmt -> [(Name, SrcLoc)]+getNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)+getNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []+getNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getNamesAndASrcLocsFromHsDecl hsDecls++-----------+-- RM Monad+-----------++newtype RM a = RM (RWS Env (Map.Map Name Name,[Warning]) ScopeState a)+    deriving(Monad,Functor,MonadReader Env, MonadWriter (Map.Map Name Name,[Warning]), MonadState ScopeState)++unRM (RM x) = x++instance Applicative RM where+    pure = return+    (<*>) = ap++instance MonadWarn RM where+    addWarning w = tell (mempty,[w])++instance UniqueProducer RM where+    newUniq = do+        ScopeState u <- get+        modify (\(ScopeState s) -> ScopeState (1 + s))+        return u++getCurrentModule :: RM Module+getCurrentModule = asks envModule++instance MonadSrcLoc RM where+    getSrcLoc = asks envSrcLoc+instance MonadSetSrcLoc RM where+    withSrcLoc sl a = local (\s -> s { envSrcLoc = sl `mappend` envSrcLoc s}) a+instance OptionMonad RM where+    getOptions = asks envOptions++class DeNameable a where+    deName :: Module -> a -> a++instance (Functor f,DeNameable a) => DeNameable (f a) where+    deName m fx = fmap (deName m) fx++instance DeNameable Name where+    deName mod name = mapName' fm unRenameString name where+        fm (Just m) | m == mod = Nothing+                    | m `elem` removedMods = Nothing+        fm m = m+        removedMods = map toModule [+            "Prelude","Jhc.Basics","Jhc.Prim.IO","Jhc.Type.Word","Jhc.Type.Basic"]++instance DeNameable HsPat where+    deName mod p = f p where+        f (HsPVar v) = HsPVar (deName mod v)+        f (HsPNeg p) = HsPNeg (f p)+        f (HsPIrrPat p) = HsPIrrPat (deName mod p)+        f (HsPBangPat p) = HsPBangPat (deName mod p)+        f (HsPParen p) = HsPParen (f p)+        f (HsPApp cn pats) = HsPApp (deName mod cn) (deName mod pats)+        f (HsPList pats) = HsPList (deName mod pats)+        f (HsPAsPat n p) = HsPAsPat (deName mod n) (deName mod p)+        f p = p++--instance DeNameable n => DeNameable Located l n where+--    deName mod p++instance DeNameable HsAlt where+    deName _ n = n++instance DeNameable HsExp where+    deName mod e = f e where+        dn :: DeNameable b => b -> b+        dn n = deName mod n+        f (HsVar hsName) = HsVar (dn hsName)+        f (HsCon hsName) = HsCon (dn hsName)+        f (HsLambda srcLoc hsPats hsExp) =+            HsLambda srcLoc (dn hsPats) (dn hsExp)+        f (HsCase hsExp hsAlts) =+            HsCase (dn hsExp) (dn hsAlts)+        f p = runIdentity $ traverseHsExp (return . dn) p+--        f (HsDo hsStmts) = do+--        (ss,()) <- renameHsStmts hsStmts (return ())+--        doToExp newVar (nameName v_bind) (nameName v_bind_) (nameName v_fail) ss+--    rename (HsRecConstr hsName hsFieldUpdates) = do+--        hsName' <- renameValName hsName+--        hsFieldUpdates' <- rename hsFieldUpdates+--        fls <- asks envFieldLabels+--        buildRecConstr fls hsName' (hsFieldUpdates'::[HsFieldUpdate])+--    rename (HsRecUpdate hsExp hsFieldUpdates) = do+--        hsExp' <- rename hsExp+--        hsFieldUpdates' <- rename hsFieldUpdates+--        fls <- asks envFieldLabels+--        buildRecUpdate fls hsExp' hsFieldUpdates' -- HsRecConstr hsName' hsFieldUpdates')+        --return (HsRecUpdate hsExp' hsFieldUpdates')+--    rename (HsListComp hsExp hsStmts) = do+--        (ss,e) <- renameHsStmts hsStmts (rename hsExp)+--        listCompToExp newVar e ss+--    rename (HsExpTypeSig srcLoc hsExp hsQualType) = do+--        hsExp' <- rename hsExp+--        updateWith hsQualType $ do+--            hsQualType' <- rename hsQualType+--            return (HsExpTypeSig srcLoc hsExp' hsQualType')+--    rename (HsAsPat hsName hsExp) = HsAsPat <$> renameValName hsName <*> rename hsExp+--    rename (HsWildCard sl) = do+--        withSrcLoc sl $ do+--            e <- createError HsErrorUnderscore ("_")+--            return e
+ src/FrontEnd/Syn/Options.hs view
@@ -0,0 +1,46 @@+module FrontEnd.Syn.Options(parseOptions) where++import Data.Char+import Data.List+import Text.ParserCombinators.ReadP++parseOptions :: String -> [(String,String)]+parseOptions s = case readP_to_S parse s of+    os -> head $ sortBy (\x y -> compare (negate $ length x) (negate $ length y)) [ x | (x,_) <- os ]++token x = x >>= \r -> spaces >> return r++parse = do+    spaces+    many (token pragma)++spaces = do+    skipSpaces+    optional (comment >> spaces)++pragma = do+    string "{-#"+    skipSpaces+    nn <- munch1 (\c -> isAlpha c || c == '_')+    skipSpaces+    body <- manyTill get (string "#-}")+    return $ (nn,body)++comment = plone +++ pline +++ line +++ block where+    line = do+        string "--"+        manyTill get (char '\n')+        return ()+    pline = do+        string "# "+        manyTill get (char '\n')+        return ()+    plone = do+        string "#line "+        manyTill get (char '\n')+        return ()+    block = do+        string "{-"+        satisfy (/= '#')+        manyTill get (string "-}")+        return ()
+ src/FrontEnd/Syn/Traverse.hs view
@@ -0,0 +1,280 @@+module FrontEnd.Syn.Traverse where++import Control.Monad.Writer+import qualified Data.Set as Set+import qualified Data.Traversable as T++import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import Name.Name+import Support.FreeVars++--instance FreeVars HsType (Set.Set HsName) where+--    freeVars t = execWriter (f t) where+--        f (HsTyVar v) = tell (Set.singleton v)+--        f t = traverseHsType_ f t++instance FreeVars HsType (Set.Set Name) where+    freeVars t = execWriter (f t) where+        f (HsTyVar v) = tell (Set.singleton $ toName TypeVal v)+        f (HsTyCon v) = tell (Set.singleton $ toName TypeConstructor v)+        f t = traverseHsType_ f t++traverse_ :: Monad m => (a -> m b) -> a -> m a+traverse_ fn x = fn x >> return x++traverseHsExp_ :: MonadSetSrcLoc m => (HsExp -> m ()) -> HsExp -> m ()+traverseHsExp_ fn e = traverseHsExp (traverse_ fn) e >> return ()++traverseHsExp :: MonadSetSrcLoc m => (HsExp -> m HsExp) -> HsExp -> m HsExp+traverseHsExp fn e = f e where+    fns = mapM fn+    f e@HsVar {} = return e+    f e@HsCon {} = return e+    f e@HsLit {} = return e+    f e@HsError {} = return e+    f (HsInfixApp hsExp1 hsExp2 hsExp3) = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        hsExp3' <- fn hsExp3+        return (HsInfixApp hsExp1' hsExp2' hsExp3')+    f (HsApp hsExp1 hsExp2)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        return (HsApp hsExp1' hsExp2')+    f (HsNegApp hsExp)  = do+        hsExp' <- fn hsExp+        return (HsNegApp hsExp')+    f (HsLambda srcLoc hsPats hsExp) = withSrcLoc srcLoc $ do+        hsExp' <- fn hsExp+        return (HsLambda srcLoc hsPats hsExp')+    f (HsIf hsExp1 hsExp2 hsExp3)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        hsExp3' <- fn hsExp3+        return (HsIf hsExp1' hsExp2' hsExp3')+    f (HsTuple hsExps)  = do+        hsExps' <- fns hsExps+        return (HsTuple hsExps')+    f (HsUnboxedTuple hsExps)  = do+        hsExps' <- fns hsExps+        return (HsUnboxedTuple hsExps')+    f (HsList hsExps)  = do+        hsExps' <- fns hsExps+        return (HsList hsExps')+    f (HsParen hsExp)  = do+        hsExp' <- fn hsExp+        return (HsParen hsExp')+    f (HsLeftSection hsExp1 hsExp2)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        return (HsLeftSection hsExp1' hsExp2')+    f (HsRightSection hsExp1 hsExp2)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        return (HsRightSection hsExp1' hsExp2')+    f (HsEnumFrom hsExp)  = do+        hsExp' <- fn hsExp+        return (HsEnumFrom hsExp')+    f (HsEnumFromTo hsExp1 hsExp2)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        return (HsEnumFromTo hsExp1' hsExp2')+    f (HsEnumFromThen hsExp1 hsExp2)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        return (HsEnumFromThen hsExp1' hsExp2')+    f (HsEnumFromThenTo hsExp1 hsExp2 hsExp3)  = do+        hsExp1' <- fn hsExp1+        hsExp2' <- fn hsExp2+        hsExp3' <- fn hsExp3+        return (HsEnumFromThenTo hsExp1' hsExp2' hsExp3')+    f (HsExpTypeSig srcLoc hsExp hsQualType)  = withSrcLoc srcLoc $ do+        hsExp' <- fn hsExp+        return (HsExpTypeSig srcLoc hsExp' hsQualType)+    f (HsAsPat hsName hsExp)  = do+        hsExp' <- fn hsExp+        return (HsAsPat hsName hsExp')+    f (HsWildCard x) = do return (HsWildCard x)+    f (HsIrrPat hsExp)  = do+        hsExp' <- fnl hsExp+        return (HsIrrPat hsExp')+    f (HsBangPat hsExp)  = do+        hsExp' <- fnl hsExp+        return (HsBangPat hsExp')+    f (HsRecConstr n fus) = do+        fus' <- mapM fFieldUpdate fus+        return $ HsRecConstr n fus'+    f (HsRecUpdate e fus) = do+        fus' <- mapM fFieldUpdate fus+        e' <- fn e+        return $ HsRecUpdate e' fus'+    f (HsLocatedExp le) = HsLocatedExp `liftM` fnl le+    f (HsLet hsDecls hsExp)  = do+        ds <- mapM (traverseHsDeclHsExp fn) hsDecls+        e <- fn hsExp+        return $ HsLet ds e+    f (HsDo hsStmts)  = HsDo `liftM` mapM (traverseHsStmtHsExp fn) hsStmts+    f _ = error "FrontEnd.Syn.Traverse.traverseHsExp f unrecognized construct"+    fFieldUpdate (HsFieldUpdate n e) = do+        e' <- fn e+        return $ HsFieldUpdate n e'+    fnl (Located l e) = withSrcSpan l $ Located l `liftM` fn e++    {-+-- not done+    f (HsRecUpdate hsExp hsFieldUpdates)  = do+        hsExp' <- fn hsExp+        hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates+        return (HsRecUpdate hsExp' hsFieldUpdates')+    fn (HsRecConstr hsName hsFieldUpdates)  = do+        hsName' <- renameHsName hsName   -- do I need to change this name?+        hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates+        return (HsRecConstr hsName' hsFieldUpdates')+--    fn (HsCase hsExp hsAlts)  = do+--        hsExp' <- fn hsExp+--        hsAlts' <- renameHsAlts hsAlts+--        return (HsCase hsExp' hsAlts')+--    fn (HsDo hsStmts)  = do+--        let e = doToExp hsStmts+--        fn e+        --(hsStmts',_) <- renameHsStmts hsStmts+        --return (doToExp hsStmts')+    fn (HsListComp hsExp hsStmts)  = do+        (hsStmts',') <- renameHsStmts hsStmts+        hsExp' <- fn hsExp '+        return (HsListComp hsExp' hsStmts')+    fn (HsLet hsDecls hsExp)  = do+        ' <- updateSubTableWithHsDecls  hsDecls LetFun+        hsDecls' <- renameHsDecls hsDecls '+        hsExp' <- fn hsExp '+        return (HsLet hsDecls' hsExp')++-}++traverseHsType_ :: Monad m => (HsType -> m b) -> HsType -> m ()+traverseHsType_ fn p = traverseHsType (traverse_ fn) p >> return ()++traverseHsType :: Monad m => (HsType -> m HsType) -> HsType -> m HsType+traverseHsType f (HsTyFun a b) = return HsTyFun `ap` f a `ap` f b+traverseHsType f (HsTyTuple xs) = do+    xs <- mapM f xs+    return $ HsTyTuple xs+traverseHsType f (HsTyUnboxedTuple xs) = do+    xs <- mapM f xs+    return $ HsTyUnboxedTuple xs+traverseHsType f (HsTyApp a b) = return HsTyApp `ap` f a `ap` f b+traverseHsType f (HsTyForall vs qt) = doQual HsTyForall f vs qt+traverseHsType f (HsTyExists vs qt) = doQual HsTyExists f vs qt+traverseHsType _ x@HsTyVar {} = return x+traverseHsType _ x@HsTyCon {} = return x+traverseHsType f HsTyExpKind { .. } = do+    hsTyLType <- T.mapM f hsTyLType+    return HsTyExpKind { .. }+traverseHsType f (HsTyEq a b) = return HsTyEq `ap` f a `ap` f b+traverseHsType f (HsTyStrictType a b ) = return HsTyStrictType `ap` return a `ap` T.mapM f b+traverseHsType _ HsTyAssoc = return HsTyAssoc++doQual :: Monad m => (a -> HsQualType -> b) -> (HsType -> m HsType) -> a -> HsQualType -> m b+doQual hsTyForall f vs qt = do+    x <- f $ hsQualTypeType qt+    cntx <- flip mapM (hsQualTypeContext qt) $ \v -> case v of+        x@HsAsst {} -> return x+        HsAsstEq a b -> return HsAsstEq `ap` f a `ap` f b+    return $ hsTyForall vs qt { hsQualTypeContext = cntx, hsQualTypeType = x }++traverseHsPat_ :: MonadSetSrcLoc m => (HsPat -> m b) -> HsPat -> m ()+traverseHsPat_ fn p = traverseHsPat (traverse_ fn) p >> return ()++traverseHsPat :: MonadSetSrcLoc m => (HsPat -> m HsPat) -> HsPat -> m HsPat+traverseHsPat fn p = f p where+    f p@HsPVar {} = return p+    f p@HsPLit {} = return p+    f (HsPNeg hsPat)  = do+          hsPat' <- fn hsPat+          return (HsPNeg hsPat')+    f (HsPInfixApp hsPat1 hsName hsPat2)  = do+          hsPat1' <- fn hsPat1+          hsPat2' <- fn hsPat2+          return (HsPInfixApp hsPat1' hsName hsPat2')+    f (HsPApp hsName hsPats)  = do+          hsPats' <- mapM fn hsPats+          return (HsPApp hsName hsPats')+    f (HsPTuple hsPats)  = do+          hsPats' <- mapM fn hsPats+          return (HsPTuple hsPats')+    f (HsPUnboxedTuple hsPats)  = do+          hsPats' <- mapM fn hsPats+          return (HsPUnboxedTuple hsPats')+    f (HsPList hsPats)  = do+          hsPats' <- mapM fn hsPats+          return (HsPList hsPats')+    f (HsPParen hsPat)  = do+          hsPat' <- fn hsPat+          return (HsPParen hsPat')+    f (HsPAsPat hsName hsPat)  = do+          hsPat' <- fn hsPat+          return (HsPAsPat hsName hsPat')+    f HsPWildCard  = do return HsPWildCard+    f (HsPIrrPat hsPat)  = do+          hsPat' <- fnl hsPat+          return (HsPIrrPat hsPat')+    f (HsPBangPat hsPat)  = do+          hsPat' <- fnl hsPat+          return (HsPBangPat hsPat')+    f (HsPTypeSig srcLoc hsPat qt) = withSrcLoc srcLoc $ do+          hsPat' <- fn hsPat+          return (HsPTypeSig srcLoc hsPat' qt)+    f (HsPRec hsName hsPatFields)  = do+          hsPatFields' <- mapM fField hsPatFields+          return (HsPRec hsName hsPatFields')+    fField (HsPFieldPat n p) = fn p >>= return . HsPFieldPat n+    fnl (Located l e) = withSrcSpan l (Located l `liftM` fn e)++traverseHsRhsHsExp :: MonadSetSrcLoc m => (HsExp -> m HsExp) -> HsRhs -> m HsRhs+traverseHsRhsHsExp fn d = f d where+    f (HsUnGuardedRhs e) = fn e >>= return . HsUnGuardedRhs+    f (HsGuardedRhss rs) = return HsGuardedRhss `ap` mapM g rs+    g (HsGuardedRhs sl e1 e2) = return (HsGuardedRhs sl) `ap` fn e1 `ap` fn e2++traverseHsStmtHsExp :: MonadSetSrcLoc m => (HsExp -> m HsExp) -> HsStmt -> m HsStmt+traverseHsStmtHsExp fn d = f d where+    f (HsGenerator sl p e) = withSrcLoc sl $ HsGenerator sl p `liftM` fn e+    f (HsQualifier e) = HsQualifier `liftM` fn e+    f (HsLetStmt ds) = HsLetStmt `liftM` mapM (traverseHsDeclHsExp fn) ds++traverseHsDeclHsExp :: MonadSetSrcLoc m => (HsExp -> m HsExp) -> HsDecl -> m HsDecl+traverseHsDeclHsExp fn d = f d where+    f (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = withSrcLoc srcLoc $ do+        hsDecls'  <- mapM (traverseHsDeclHsExp fn) hsDecls+        hsRhs'    <- traverseHsRhsHsExp fn hsRhs+        return (HsPatBind srcLoc hsPat hsRhs' {-where-} hsDecls')+    f (HsActionDecl sl p e) = withSrcLoc sl $ do+        e <- fn e+        return $ HsActionDecl sl p e+--    f (HsFunBind hsMatches)  = do+--        hsMatches'     <- mapM (traverseHsMatchHsExp fn) hsMatches+--        return (HsFunBind hsMatches')+    f (HsClassDecl srcLoc hsQualType hsDecls)  = withSrcLoc srcLoc $ do+        hsDecls'  <- mapM (traverseHsDeclHsExp fn) hsDecls+        return (HsClassDecl srcLoc hsQualType hsDecls')+    f decl@(HsClassAliasDecl { hsDeclSrcLoc = sl})  = withSrcLoc sl $ do+        hsDecls'  <- mapM (traverseHsDeclHsExp fn) (hsDeclDecls decl)+        return (decl { hsDeclDecls = hsDecls' })+    f (HsInstDecl srcLoc hsQualType hsDecls)  = withSrcLoc srcLoc $ do+        hsDecls'  <- mapM (traverseHsDeclHsExp fn) hsDecls+        return (HsInstDecl srcLoc hsQualType hsDecls')+--    f prules@HsPragmaRules { hsDeclSrcLoc = srcLoc, hsDeclFreeVars = fvs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2 }  = withSrcLoc srcLoc $ do+--        fvs' <- sequence [ fmapM (`renameHsType` ) t  >>= return . (,) n | (n,t) <- fvs]+--        e1' <- renameHsExp e1+--        e2' <- renameHsExp e2+--        return prules {  hsDeclFreeVars = fvs', hsDeclLeftExpr = e1', hsDeclRightExpr = e2' }+    f otherHsDecl = return otherHsDecl++getNamesFromHsPat :: HsPat -> [HsName]+getNamesFromHsPat p = execWriter (getNamesFromPat p) where+    getNamesFromPat (HsPVar hsName) = tell [toName Val hsName]+    getNamesFromPat (HsPAsPat hsName hsPat) = do+        tell [toName Val hsName]+        getNamesFromPat hsPat+    getNamesFromPat p = traverseHsPat_ getNamesFromPat p
+ src/FrontEnd/Tc/Class.hs view
@@ -0,0 +1,263 @@+module FrontEnd.Tc.Class(+    Pred,+    ClassHierarchy(),+    splitPreds,+    generalize,+    splitReduce,+    topDefaults,+    freeMetaVarsPreds,+    simplify,+    assertEntailment,+    assertEquivalant,+    Preds+    )where++import Control.Monad.Trans+import Data.Monoid+import Data.List+import Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set++import Doc.DocLike+import Doc.PPrint+import FrontEnd.Class+import FrontEnd.Tc.Monad+import FrontEnd.Tc.Type+import Name.Name+import Name.Names+import Options+import Support.CanType+import qualified FlagDump as FD+import qualified FlagOpts as FO++generalize :: [Pred] -> Rho -> Tc Sigma+generalize ps r = do+    ch <- getClassHierarchy+    r <- flattenType r+    fmvenv <- freeMetaVarsEnv+    let mvs =  freeMetaVars r `Set.difference` fmvenv+    --(nps,rp) <- splitPreds ch (Set.toList fmvenv) ps+    (mvs',nps,rp) <- splitReduce fmvenv mvs (simplify ch ps)+    addPreds nps+    quantify mvs' rp r++freeMetaVarsPreds :: Preds -> Set.Set MetaVar+freeMetaVarsPreds ps = Set.unions (map freeMetaVarsPred ps)++freeMetaVarsPred :: Pred -> Set.Set MetaVar+freeMetaVarsPred (IsIn _ t) = freeMetaVars t+freeMetaVarsPred (IsEq t1 t2) = freeMetaVars t1 `Set.union` freeMetaVars t2++-- | split predicates into ones that only mention metavars in the list vs other ones+splitPreds :: Monad m+           => ClassHierarchy+           -> Set.Set MetaVar+           -> Preds+           -> m (Preds, Preds)+splitPreds h fs ps  = do+    ps' <- toHnfs h ps+    return $ partition (\p -> let fv = freeMetaVarsPred p in not (Set.null fv) && fv `Set.isSubsetOf` fs) $ simplify h ps'++toHnfs      :: Monad m => ClassHierarchy -> [Pred] -> m [Pred]+toHnfs h ps =  mapM (toHnf h) ps >>= return . concat++toHnf :: Monad m => ClassHierarchy -> Pred -> m [Pred]+toHnf h p+    | inHnf p = return [p]+    | otherwise =  case reducePred h p of+         Nothing -> fail $ "context reduction, no instance for: "  ++ (pprint  p)+         Just ps -> toHnfs h ps++inHnf       :: Pred -> Bool+inHnf (IsEq t1 t2) = True+inHnf (IsIn c t) = hnf t+ where hnf (TVar v)  = True+       hnf TMetaVar {} = True+       hnf (TCon tc) = False+       hnf (TAp t _) = hnf t+       hnf (TArrow _t1 _t2) = False+       hnf TForAll {} = False+       hnf TExists {} = False+       hnf TAssoc {} = True++reducePred :: Monad m => ClassHierarchy -> Pred -> m [Pred]+reducePred h p@(IsEq t1 t2) = fail "reducePred" -- return [p]+reducePred h p@(IsIn c t)+    | Just x <- foldr mplus Nothing poss = return x+    | otherwise = fail "reducePred"+ where poss = map (byInst p) (instsOf h c)++simplify :: ClassHierarchy -> [Pred] -> [Pred]+simplify h ps = loop [] ps where+    loop rs []     = rs+    loop rs (p:ps)+        | entails h (rs ++ ps) p = loop rs ps+        | otherwise = loop (p:rs) ps++-- | returns true when set of predicates implies some other predicate is satisfied.+entails :: ClassHierarchy -> [Pred] -> Pred -> Bool+--entails h ps e@(IsEq {}) = error $ pprint (ps,e)+entails h ps p = (p `elem` concatMap (bySuper h) ps) ||+           case reducePred h p of+             Nothing -> False+             Just qs -> all (entails h ps) qs++bySuper :: ClassHierarchy -> Pred -> [Pred]+bySuper h p@IsEq {} = [p]+bySuper h p@(IsIn c t)+ = p : concatMap (bySuper h) supers+   where supers = [ IsIn c' t | c' <- supersOf h c ]++byInst             :: Monad m => Pred -> Inst -> m [Pred]+byInst p Inst { instHead = ps :=> h } = do+    u <- matchPred h p+    return (map (inst mempty (Map.fromList [ (tyvarName mv,t) | (mv,t) <- u ])) ps)++matchPred :: Monad m => Pred -> Pred -> m [(Tyvar,Type)]+matchPred x@(IsIn c t) y@(IsIn c' t')+      | c == c'   = match t t'+matchPred x y = fail $ "Classes do not match: " ++ show (x,y)++supersOf :: ClassHierarchy -> Class -> [Class]+supersOf ch c = asksClassRecord ch c classSupers+instsOf :: ClassHierarchy -> Class -> [Inst]+--instsOf ch c = asksClassRecord ch c classInsts+instsOf ch c = findClassInsts ch c++match :: Monad m => Type -> Type -> m [(Tyvar,Type)]+match x y = do match' x y+match' (TAp l r) (TAp l' r') = do+    sl <- match l l'+    sr <- match r r'+    return $ mappend sl sr+match' (TArrow l r) (TArrow l' r') = do+    sl <- match l l'+    sr <- match r r'+    return $ mappend sl sr+match' (TVar u) (TVar t) | u == t = return mempty+match' (TVar mv) t | getType mv == getType t = return [(mv,t)]+--match' (TMetaVar mv) t | kind mv == kind t = return [(mv,t)]+match' (TCon tc1) (TCon tc2) | tc1==tc2 = return mempty+match' t1 t2  = fail $ "match: " ++ show (t1,t2)++splitReduce :: Set.Set MetaVar -- ^ Meta vars from the environment+            -> Set.Set MetaVar -- ???+            -> [Pred]          -- ^ Relevant predicates+            -> Tc ([MetaVar], [Pred], [Pred]) -- ^ (retained ??? meta-vars, untouched predicates, altered predicates)+splitReduce fs gs ps = do+    h <- getClassHierarchy+    --liftIO $ putStrLn $ pprint (fs,gs,ps)+    (ds, rs) <- splitPreds h fs ps+    --liftIO $ putStrLn $ pprint (ds,rs)+    let (rs',sub) = genDefaults h (fs `Set.union` gs) rs+    --liftIO $ putStrLn $ pprint (rs')+    flip mapM_ sub $ \ (x,y) ->  do+        let msg = "defaulting: " <+> pprint x <+> "=>" <+> prettyPrintType y+        wdump FD.BoxySteps $ liftIO $ putStrLn msg+        --addWarn "type-defaults" msg+    sequence_ [ varBind x y | (x,y) <- nub sub]+    return (Set.toList gs Data.List.\\ map fst sub, ds, rs')++-- | Return retained predicates and a defaulting substitution+genDefaults :: ClassHierarchy+            -> Set.Set MetaVar -- ^ Variables to be considered known+            -> [Pred]          -- ^ Predicates to examine+            -> ([Pred], [(MetaVar,Type)])+genDefaults h vs ps = (ps \\ ps',  vs')+ where ams = [ (v,qs,t) | (v,qs,t:ts) <- ambig h vs ps ]+       ps' = [ p | (v,qs,ts) <- ams, p <-qs ]+       vs' = [ (v,t)  | (v,qs,t) <- ams ]++-- ambiguities from THIH + call to candidates+ambig :: ClassHierarchy+      -> Set.Set MetaVar -- ^ Variables that are to be considered known+      -> [Pred]          -- ^ Predicates to consider+      -> [(MetaVar, [Pred], [Type])] -- ^ List of (ambiguous meta var, predicates involving it, potential defaults)++ambig h vs ps+  = [ (v, qs, defs h v qs) |+         v <- Set.toList (freeMetaVarsPreds ps `Set.difference` vs),+         let qs = [ p | p<-ps, v `Set.member` freeMetaVarsPred p ] ]++assertEntailment :: Preds -> Preds -> Tc ()+assertEntailment qs ps = do+--    liftIO $ putStrLn $ "Asserting entailment: " ++ pprint (qs,ps)+    ch <- getClassHierarchy+    let ns = [ p  | p <- ps, not $ entails ch qs p ]+    if null ns then return () else+        fail $ "Signature too Weak: " ++ pprint qs ++ " does not imply " ++ pprint ns++assertEquivalant :: Preds -> Preds -> Tc ()+assertEquivalant qs ps = do+    assertEntailment qs ps+    assertEntailment ps qs+{-++reduce :: OptionMonad m => ClassHierarchy -> [Tyvar] -> [Tyvar] -> [Pred] -> m ([Pred], [Pred])++reduce h fs gs ps = do+    (ds, rs) <- split h fs ps+    rs' <-   useDefaults h (fs++gs) rs+    return (ds,rs')+-}++-- 'candidates' from THIH+defs     :: ClassHierarchy -> MetaVar -> [Pred] -> [Type]+defs h v qs = [ t | all ((TMetaVar v)==) ts,+                  all (`elem` stdClasses) cs, -- XXX needs fixing+                  any (`elem` numClasses) cs, -- XXX needs fixing+                  t <- defaults, -- XXX needs fixing+                  and [ entails h [] (IsIn c t) | c <- cs ]]+ where cs = [ c | (IsIn c t) <- qs ]+       ts = [ t | (IsIn c t) <- qs ]++-- FIXME use @default@ declarations!+defaults    :: [Type]+defaults+    | not $ fopts FO.Defaulting = []+    | otherwise = map (\name -> TCon (Tycon name kindStar)) [tc_Integer, tc_Double]++topDefaults     :: [Pred] -> Tc ()+topDefaults ps  = do+    h <- getClassHierarchy+    let ams = ambig h Set.empty ps+        tss = [ ts | (v,qs,ts) <- ams ]+        _vs  = [ v  | (v,qs,ts) <- ams ]+    when (any null tss) $ fail $ "Top Level ambiguity " ++ (pprint ps)+    return ()+--      | otherwise    -> return $ Map.fromList (zip vs (map head tss))+--        where ams = ambig h [] ps+--              tss = [ ts | (v,qs,ts) <- ams ]+--              vs  = [ v  | (v,qs,ts) <- ams ]++numClasses,stdClasses :: [Name]++stdClasses = [+    class_Eq,+    class_Ord,+    class_Enum,+    class_Bounded,+    class_Show,+    class_Read,+    class_Ix,+    class_Functor,+    class_Monad,+    class_Num ,+    class_Real,+    class_Integral,+    class_Fractional,+    class_Floating,+    class_RealFrac,+    class_RealFloat+    ]++numClasses = [+    class_Num ,+    class_Real,+    class_Integral,+    class_Fractional,+    class_Floating,+    class_RealFrac,+    class_RealFloat+    ]
+ src/FrontEnd/Tc/Class.hs-boot view
@@ -0,0 +1,7 @@+module FrontEnd.Tc.Class(simplify,FrontEnd.Class.ClassHierarchy) where++import FrontEnd.Class+import FrontEnd.Tc.Type+++simplify :: ClassHierarchy -> [Pred] -> [Pred]
+ src/FrontEnd/Tc/Main.hs view
@@ -0,0 +1,900 @@+module FrontEnd.Tc.Main (tiExpr, tiProgram, makeProgram, isTypePlaceholder ) where++import Control.Monad.Reader+import Control.Monad.Writer+import Data.Graph(stronglyConnComp, SCC(..))+import System.IO(hPutStr,stderr)+import Text.Printf+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Text.PrettyPrint.HughesPJ as P++import Doc.DocLike+import Doc.PPrint as PPrint+import FrontEnd.Class+import FrontEnd.DeclsDepends(getDeclDeps)+import FrontEnd.Diagnostic+import FrontEnd.HsPretty+import FrontEnd.HsSyn+import FrontEnd.KindInfer+import FrontEnd.SrcLoc+import FrontEnd.Tc.Class+import FrontEnd.Tc.Kind+import FrontEnd.Tc.Monad hiding(listenPreds)+import FrontEnd.Tc.Type+import FrontEnd.Tc.Unify+import FrontEnd.Utils(getDeclName,maybeGetDeclName)+import FrontEnd.Warning+import GenUtil+import Name.Name+import Name.Names+import Name.VConsts+import Options+import Support.FreeVars+import Util.Progress+import qualified FlagDump as FD+import qualified FlagOpts as FO++listenPreds = listenSolvePreds++type Expl = (Sigma, HsDecl)+-- TODO: this is different than the "Typing Haskell in Haskell" paper+-- we do not further sub-divide the implicitly typed declarations in+-- a binding group.+type BindGroup = ([Expl], [Either HsDecl [HsDecl]])++tpretty vv = prettyPrintType vv+tppretty vv = parens (tpretty vv)++tcKnownApp e coerce vname as typ = do+    sc <- lookupName vname+    let (_,_,rt) = fromType sc+    -- fall through if the type isn't arrowy enough (will produce type error)+    if (length . fst $ fromTArrow rt) < length as then tcApps' e as typ else do+    (ts,rt) <- freshInstance Sigma sc+    e' <- if coerce then doCoerce (ctAp ts) e else return e+    --addCoerce nname (ctAp ts)+    let f (TArrow x y) (a:as) = do+            a <- tcExprPoly a x+            y <- evalType y+            (as,fc) <- f y as+            return (a:as,fc)+        f lt [] = do+            fc <- lt `subsumes` typ+            return ([],fc)+        f _ _ = error "Main.tcKnownApp: bad."+    (nas,CTId) <- f rt as+    return (e',nas)++tcApps e@(HsVar v) as typ = do+    let vname = toName Val v+    --let nname = toName Val n+    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "tcApps: " ++ (show vname)+    rc <- asks tcRecursiveCalls+    -- fall through if this is a recursive call to oneself+    if (vname `Set.member` rc) then tcApps' e as typ else do+    tcKnownApp e True vname as typ++tcApps e@(HsCon v) as typ = do+    (e,nname) <- wrapInAsPat e+    let vname = toName DataConstructor v+    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "tcApps: " ++ (show nname ++ "@" ++ show vname)+    addToCollectedEnv (Map.singleton nname typ)+    tcKnownApp e False vname as typ++tcApps e as typ = tcApps' e as typ++-- the fall through case+tcApps' e as typ = do+    printRule $ "tcApps': " ++ (show e)+    bs <- sequence [ newBox kindArg | _ <- as ]+    e' <- tcExpr e (foldr fn typ bs)+    as' <- sequence [ tcExprPoly a r | r <- bs | a <- as ]+    return (e',as')++tcApp e1 e2 typ = do+    (e1,[e2]) <- tcApps e1 [e2] typ+    return (e1,e2)++tiExprPoly,tcExprPoly ::  HsExp -> Type ->  Tc HsExp++tcExprPoly e t = do+    t <- evalType t+    printRule $ "tiExprPoly " ++ tppretty t <+> show e+    tiExprPoly e t++tiExprPoly e t@TMetaVar {} = tcExpr e t   -- GEN2+tiExprPoly e t = do                   -- GEN1+    (ts,_,t) <- skolomize t+    e <- tcExpr e t+    doCoerce (ctAbs ts) e++doCoerce :: CoerceTerm -> HsExp -> Tc HsExp+doCoerce CTId e = return e+doCoerce ct e = do+    (e',n) <- wrapInAsPat e+    addCoerce n ct+    return e'++wrapInAsPat :: HsExp -> Tc (HsExp,Name)+wrapInAsPat e = do+    n <- newHsVar "As"+    return (HsAsPat (nameName n) e, n)++wrapInAsPatEnv :: HsExp -> Type -> Tc HsExp+wrapInAsPatEnv e typ = do+    (ne,ap) <- wrapInAsPat e+    addToCollectedEnv (Map.singleton ap typ)+    return ne++newHsVar ns = do+    nn <- newUniq+    return $ toName Val (ns ++ "@",show nn)++isTypePlaceholder :: HsName -> Bool+isTypePlaceholder (getModule -> Just m) = m `elem` [toModule "Wild@",toModule "As@"]+isTypePlaceholder _ = False++tiExpr,tcExpr ::  HsExp -> Type ->  Tc HsExp++tcExpr e t = do+    t <- evalType t+    e <- tiExpr e t+    --(_,False,_) <- unbox t+    return e++tiExpr (HsVar v) typ = do+    sc <- lookupName (toName Val v)+    f <- sc `subsumes` typ+    rc <- asks tcRecursiveCalls+    if (toName Val v `Set.member` rc) then do+        (e',n) <- wrapInAsPat (HsVar v)+        tell mempty { outKnots = [(n,toName Val v)] }+        return e'+      else do+        doCoerce f (HsVar v)++tiExpr (HsCase e alts) typ = do+    dn <- getDeName+    withContext (simpleMsg $ "in the case expression\n   case " ++ render (ppHsExp $ dn e) ++ " of ...") $ do+    scrutinee <- newBox kindFunRet+    e' <- tcExpr e scrutinee+    alts' <- mapM (tcAlt scrutinee typ) alts+    wrapInAsPatEnv (HsCase e' alts') typ++tiExpr (HsCon conName) typ = do+    sc <- lookupName (toName DataConstructor conName)+    sc `subsumes` typ+    wrapInAsPatEnv (HsCon conName) typ++tiExpr (HsLit l@(HsIntPrim _)) typ = do+    unBox typ+    ty <- evalType typ+    case ty of+        TCon (Tycon n kh) | kh == kindHash -> return ()+        _ -> ty `boxyMatch` (TCon (Tycon tc_Bits32 kindHash))+    wrapInAsPatEnv (HsLit l) ty++tiExpr (HsLit l@(HsInt _)) typ = do+    t <- tiLit l+    t `subsumes` typ+    wrapInAsPatEnv (HsLit l) typ++tiExpr err@HsError {} typ = do+    unBox typ+    wrapInAsPatEnv err typ++tiExpr (HsLit l) typ = do+    t <- tiLit l+    t `subsumes` typ+    return (HsLit l)++tiExpr (HsAsPat n e) typ = do+    e <- tcExpr e typ+    --typ <- flattenType typ+    addToCollectedEnv (Map.singleton (toName Val n) typ)+    return (HsAsPat n e)++-- comb LET-S and VAR+tiExpr expr@(HsExpTypeSig sloc e qt) typ =+    deNameContext (Just sloc) "in the annotated expression" expr $ do+    kt <- getKindEnv+    s <- hsQualTypeToSigma kt qt+    s `subsumes` typ+    e' <- tcExpr e typ+    return (HsExpTypeSig sloc e' qt)++tiExpr (HsLeftSection e1 e2) typ = do+    (e1,e2) <- tcApp e1 e2 typ+    return (HsLeftSection e1 e2)++-- I know this looks weird but it appears to be correct+-- e1 :: b+-- e2 :: a -> b -> c+-- e1 e2 :: a -> c++-- (: [])  \x -> x : []   `fn`++tiExpr (HsRightSection e1 e2) typ = do+    arg <- newBox kindArg+    arg2 <- newBox kindArg+    ret <- newBox kindFunRet+    e1 <- tcExpr e1 arg2+    e2 <- tcExpr e2 (arg `fn` (arg2 `fn` ret))+    (arg `fn` ret) `subsumes` typ+    return (HsRightSection e1 e2)++tiExpr expr@HsApp {} typ = deNameContext Nothing "in the application" (backToApp h as) $ do+    (h,as) <- tcApps h as typ+    return $ backToApp h as+    where+    backToApp h as = foldl HsApp h as+    (h,as) = fromHsApp expr+    fromHsApp t = f t [] where+        f (HsApp a b) rs = f a (b:rs)+        f t rs = (t,rs)++tiExpr expr@(HsInfixApp e1 e2 e3) typ = deNameContext Nothing "in the infix application" expr $ do+    (e2',[e1',e3']) <- tcApps e2 [e1,e3] typ+    return (HsInfixApp e1' e2' e3')++-- we need to fix the type to to be in the class+-- cNum, just for cases such as:+-- foo = \x -> -x++tiExpr expr@(HsNegApp e) typ = deNameContext Nothing "in the negative expression" expr $ do+        e <- tcExpr e typ+        addPreds [IsIn class_Num typ]+        return (HsNegApp e)++-- ABS1+tiExpr expr@(HsLambda sloc ps e) typ = do+    dn <- getDeName+    withContext (locSimple sloc $ "in the lambda expression\n   \\" ++ show (pprint (dn ps):: P.Doc) ++ " -> ...") $ do+    let lam (p:ps) e (TMetaVar mv) rs = do -- ABS2+            withMetaVars mv [kindArg,kindFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) e (a `fn` b) rs+        lam (p:ps) e (TArrow s1' s2') rs = do -- ABS1+            --box <- newBox Star+            --s1' `boxyMatch` box+            (p',env) <- tcPat p s1'+            localEnv env $ do+                s2' <- evalType s2'+                lamPoly ps e s2' (p':rs)  -- TODO poly+        lam (p:ps) e t@(TAp (TAp (TMetaVar mv) s1') s2') rs = do+            boxyMatch (TMetaVar mv) tArrow+            (p',env) <- tcPat p s1'+            localEnv env $ do+                s2' <- evalType s2'+                lamPoly ps e s2' (p':rs)  -- TODO poly+        lam [] e typ rs = do+            e' <- tcExpr e typ+            return (HsLambda sloc (reverse rs) e')+        lam _ _ t _ = do+            t <- flattenType t+            fail $ "expected a -> b, found: " ++ prettyPrintType t+        lamPoly ps e s rs = do+            (ts,_,s) <- skolomize s+            e <- lam ps e s rs+            doCoerce (ctAbs ts) e+    lam ps e typ []++tiExpr (HsIf e e1 e2) typ = do+    dn <- getDeName+    withContext (simpleMsg $ "in the if expression\n   if " ++ show (dn e) ++ "...") $ do+    e <- tcExpr e tBool+    e1 <- tcExpr e1 typ+    e2 <- tcExpr e2 typ+    return (HsIf e e1 e2)++tiExpr tuple@(HsTuple exps@(_:_)) typ = deNameContext Nothing "in the tuple" tuple $ do+    --(_,exps') <- tcApps (HsCon (toTuple (length exps))) exps typ+    (_,exps') <- tcApps (HsCon (nameTuple TypeConstructor (length exps))) exps typ+    return (HsTuple exps')++tiExpr tuple@(HsUnboxedTuple exps) typ = deNameContext Nothing "in the unboxed tuple" tuple $ do+    (_,exps') <- tcApps (HsCon (nameName $ unboxedNameTuple DataConstructor (length exps))) exps typ+    return (HsUnboxedTuple exps')++-- special case for the empty list+tiExpr (HsList []) (TAp c v) | c == tList = do+    unBox v+    wrapInAsPatEnv (HsList []) (TAp c v)++-- special case for the empty list+tiExpr (HsList []) typ = do+    v <- newVar kindStar+    let lt = TForAll [v] ([] :=> TAp tList (TVar v))+    lt `subsumes` typ+    wrapInAsPatEnv (HsList []) typ++-- non empty list+tiExpr expr@(HsList exps@(_:_)) (TAp tList' v) | tList == tList' = deNameContext Nothing "in the list " expr $ do+        exps' <- mapM (`tcExpr` v) exps+        wrapInAsPatEnv (HsList exps') (TAp tList' v)++-- non empty list+tiExpr expr@(HsList exps@(_:_)) typ = deNameContext Nothing "in the list " expr $ do+        v <- newBox kindStar+        exps' <- mapM (`tcExpr` v) exps+        (TAp tList v) `subsumes` typ+        wrapInAsPatEnv (HsList exps') typ++tiExpr (HsParen e) typ = tcExpr e typ++--tiExpr (HsDo stmts) typ = withContext (simpleMsg "in a do expression") $ do+--        newExp <- doToExp stmts+--        tcExpr newExp typ++tiExpr expr@(HsLet decls e) typ = deNameContext Nothing "in the let binding" expr $ do+    sigEnv <- getSigEnv+    let bgs = getFunDeclsBg sigEnv decls+        f (bg:bgs) rs = do+            (ds,env) <- tcBindGroup bg+            localEnv env $ f bgs (ds ++ rs)+        f [] rs = do+            e' <- tcExpr e typ+            return (HsLet rs e')+    f bgs []++tiExpr e typ = fail $ "tiExpr: not implemented for: " ++ show (e,typ)++tcWheres :: [HsDecl] -> Tc ([HsDecl],TypeEnv)+tcWheres decls = do+    sigEnv <- getSigEnv+    let bgs = getFunDeclsBg sigEnv decls+        f (bg:bgs) rs cenv  = do+            (ds,env) <- tcBindGroup bg+            localEnv env $ f bgs (ds ++ rs) (env `mappend` cenv)+        f [] rs cenv = return (rs,cenv)+    f bgs [] mempty++deNameContext :: Maybe SrcLoc -> String -> HsExp -> Tc a -> Tc a+deNameContext sl desc e action = do+    dn <- getDeName+    let mm = maybe makeMsg locMsg  sl+    withContext (mm desc (render $ ppHsExp (dn e))) action++-----------------------------------------------------------------------------++-- type check implicitly typed bindings++tcAlt ::  Sigma -> Sigma -> HsAlt -> Tc HsAlt++tcAlt scrutinee typ alt@(HsAlt sloc pat gAlts wheres)  = withContext (locMsg sloc "in the alternative" $ render $ ppHsAlt alt) $ do+    scrutinee <- evalType scrutinee+    (pat',env) <- tcPat pat scrutinee+    localEnv env $ do+    (wheres', env) <- tcWheres wheres+    localEnv env $ case gAlts of+        HsUnGuardedRhs e -> do+            e' <- tcExpr e typ+            return (HsAlt sloc pat' (HsUnGuardedRhs e') wheres')+        HsGuardedRhss as -> do+            gas <- mapM (tcGuardedAlt typ) as+            return (HsAlt sloc pat' (HsGuardedRhss gas) wheres')++tcGuardedAlt typ gAlt@(HsGuardedRhs sloc eGuard e) = withContext (locMsg sloc "in the guarded alternative" $ render $ ppGAlt gAlt) $ do+    typ <- evalType typ+    g' <- tcExpr eGuard tBool+    e' <- tcExpr e typ+    return  (HsGuardedRhs sloc g' e')++tcGuardedRhs typ gAlt@(HsGuardedRhs sloc eGuard e) = withContext (locMsg sloc "in the guarded alternative" $ render $ ppHsGuardedRhs gAlt) $ do+    typ <- evalType typ+    g' <- tcExpr eGuard tBool+    e' <- tcExpr e typ+    return  (HsGuardedRhs sloc g' e')++-- Typing Patterns++tiPat,tcPat :: HsPat -> Type -> Tc (HsPat, Map.Map Name Sigma)++tcPat p typ = withContext (makeMsg "in the pattern: " $ render $ ppHsPat p) $ do+    typ <- evalType typ+    tiPat p typ++tiPat (HsPVar i) typ = do+        --v <- newMetaVar Tau Star+        --v `boxyMatch` typ+        --typ `subsumes` v+        typ' <- unBox typ+        addToCollectedEnv (Map.singleton (toName Val i) typ')+        return (HsPVar i, Map.singleton (toName Val i) typ')++tiPat pl@(HsPLit HsChar {}) typ = boxyMatch tChar typ >> return (pl,mempty)+tiPat pl@(HsPLit HsCharPrim {}) typ = boxyMatch tCharzh typ >> return (pl,mempty)+tiPat pl@(HsPLit HsString {}) typ = boxyMatch tString typ >> return (pl,mempty)+tiPat pl@(HsPLit HsInt {}) typ = do+    unBox typ+    addPreds [IsIn class_Num typ]+    return (pl,mempty)+tiPat pl@(HsPLit HsIntPrim {}) typ = do+    unBox typ+    ty <- evalType typ+    case ty of+        TCon (Tycon n kh) | kh == kindHash -> return ()+        _ -> ty `boxyMatch` (TCon (Tycon tc_Bits32 kindHash))+    return (pl,mempty)+tiPat pl@(HsPLit HsFrac {}) typ = do+    unBox typ+    addPreds [IsIn class_Fractional typ]+    return (pl,mempty)++{-+tiPat (HsPLit l) typ = do+    t <- tiLit l+    typ `subsumes` t -- `boxyMatch` typ+    return (HsPLit l,Map.empty)+-}+-- this is for negative literals only+-- so the pat must be a literal+-- it is safe not to make any predicates about+-- the pat, since the type checking of the literal+-- will do this for us+tiPat (HsPNeg (HsPLit (HsInt i))) typ = tiPat (HsPLit $ HsInt (negate i)) typ+tiPat (HsPNeg (HsPLit (HsFrac i))) typ = tiPat (HsPLit $ HsFrac (negate i)) typ+tiPat (HsPNeg (HsPLit (HsIntPrim i))) typ = tiPat (HsPLit $ HsIntPrim (negate i)) typ+tiPat (HsPNeg (HsPLit (HsFloatPrim i))) typ = tiPat (HsPLit $ HsFloatPrim (negate i)) typ+tiPat (HsPNeg (HsPLit (HsDoublePrim i))) typ = tiPat (HsPLit $ HsDoublePrim (negate i)) typ+tiPat (HsPNeg pat) typ = fail $ "non-literal negative patterns are not allowed"+--tiPat (HsPNeg pat) typ = tiPat pat typ++tiPat (HsPIrrPat (Located l p)) typ = do+    (p,ns) <- tiPat p typ+    return (HsPIrrPat (Located l p),ns)+tiPat (HsPBangPat (Located l p@HsPAsPat {})) typ = do+    (p,ns) <- tiPat p typ+    return (HsPBangPat (Located l p),ns)+tiPat (HsPBangPat (Located l p)) typ = do+    v <- newHsVar "Bang"+    tiPat (HsPBangPat (Located l (HsPAsPat (nameName v) p))) typ+tiPat (HsPParen p) typ = tiPat p typ++-- TODO check that constructors are saturated+tiPat (HsPApp conName pats) typ = do+    s <- lookupName (toName DataConstructor conName)+    nn <- deconstructorInstantiate s+    let f (p:pats) (a `TArrow` rs) (ps,env) = do+            (np,res) <- tiPat p a+            f pats rs (np:ps,env `mappend` res)+        f (p:pats) rs _ = do+            fail $ "constructor applied to too many arguments:" <+> show p <+> prettyPrintType rs+        f [] (_ `TArrow` _) _ = do+            fail "constructor not applied to enough arguments"+        f [] rs (ps,env) = do+            rs `subsumes` typ+            unBox typ+            return (HsPApp conName (reverse ps), env)+    f pats nn mempty+    --bs <- sequence [ newBox Star | _ <- pats ]+    --s `subsumes` (foldr fn typ bs)+    --pats' <- sequence [ tcPat a r | r <- bs | a <- pats ]+    --return (HsPApp conName (fsts pats'), mconcat (snds pats'))++tiPat pl@(HsPList []) (TAp t v) | t == tList = do+    unBox v+    return (delistPats [],mempty)++tiPat pl@(HsPList []) typ = do+    v <- newBox kindStar+    --typ `subsumes` TAp tList v+    typ `boxyMatch` TAp tList v+    return (delistPats [],mempty)++tiPat (HsPList pats@(_:_)) (TAp t v) | t == tList = do+    --v <- newBox kindStar+    --TAp tList v `boxyMatch` typ+    --typ `subsumes` TAp tList v+    ps <- mapM (`tcPat` v) pats+    return (delistPats (fsts ps), mconcat (snds ps))++tiPat (HsPList pats@(_:_)) typ = do+    v <- newBox kindStar+    --TAp tList v `boxyMatch` typ+    ps <- mapM (`tcPat` v) pats+    typ `boxyMatch` TAp tList v+    return (delistPats (fsts ps), mconcat (snds ps))++tiPat HsPWildCard typ = do+    n <- newHsVar "Wild"+    typ' <- unBox typ+    addToCollectedEnv (Map.singleton n typ')+    return (HsPVar (nameName n), Map.singleton n typ')++tiPat (HsPAsPat i pat) typ = do+    (pat',env) <- tcPat pat typ+    addToCollectedEnv (Map.singleton (toName Val i) typ)+    return (HsPAsPat i pat', Map.insert (toName Val i) typ env)++tiPat (HsPInfixApp pLeft conName pRight) typ =  tiPat (HsPApp conName [pLeft,pRight]) typ++tiPat (HsPUnboxedTuple ps) typ = tiPat (HsPApp (nameName $ unboxedNameTuple DataConstructor (length ps)) ps) typ+tiPat tuple@(HsPTuple pats) typ = tiPat (HsPApp (nameTuple DataConstructor (length pats)) pats) typ+tiPat (HsPTypeSig _ pat qt)  typ = do+    kt <- getKindEnv+    s <- hsQualTypeToSigma kt qt+    s `boxyMatch` typ+    p <- tcPat pat typ+    return p++tiPat p _ = error $ "tiPat: " ++ show p++delistPats ps = pl ps where+    pl [] = HsPApp (nameName $ dc_EmptyList) []+    pl (p:xs) = HsPApp (nameName $ dc_Cons) [p, pl xs]++tcBindGroup :: BindGroup -> Tc ([HsDecl], TypeEnv)+tcBindGroup (es, is) = do+     let env1 = Map.fromList [(getDeclName decl, sc) | (sc,decl) <- es ]+     localEnv env1 $ do+         (impls, implEnv) <- tiImplGroups is+         localEnv implEnv $ do+             expls   <- mapM tiExpl es+             return (impls ++ fsts expls, mconcat (implEnv:env1:snds expls))++tiImplGroups :: [Either HsDecl [HsDecl]] -> Tc ([HsDecl], TypeEnv)+tiImplGroups [] = return ([],mempty)+tiImplGroups (Left x:xs) = do+    (d,te) <- tiNonRecImpl x+    (ds',te') <- localEnv te $ tiImplGroups xs+    return (d:ds', te `mappend` te')+tiImplGroups (Right x:xs) = do+    (ds,te) <- tiImpls x+    (ds',te') <- localEnv te $ tiImplGroups xs+    return (ds ++ ds', te `mappend` te')++tiNonRecImpl :: HsDecl -> Tc (HsDecl, TypeEnv)+tiNonRecImpl decl = withContext (locSimple (srcLoc decl) ("in the implicitly typed: " ++ show (getDeclName decl))) $ do+    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** tiimpls " ++ show (getDeclName decl)+    mv <- newMetaVar Sigma kindStar+    (res,ps) <- listenPreds $ tcDecl decl mv+    ps' <- flattenType ps+    mv' <- flattenType mv+    fs <- freeMetaVarsEnv+    let vss = freeMetaVars mv'+        gs = vss Set.\\ fs+    (mvs,ds,rs) <- splitReduce fs vss ps'+    addPreds ds+    mr <- flagOpt FO.MonomorphismRestriction+    sc' <- if restricted mr [decl] then do+        let gs' = gs Set.\\ Set.fromList (freeVars rs)+        addPreds rs+        quantify (Set.toList gs') [] mv'+     else quantify (Set.toList gs) rs mv'+    let f n s = do+        let (TForAll vs _) = toSigma s+        addCoerce n (ctAbs vs)+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s+        return (n,s)+    (n,s) <- f (getDeclName decl) sc'+    let nenv = (Map.singleton n s)+    addToCollectedEnv nenv+    return (fst res, nenv)++tiImpls ::  [HsDecl] -> Tc ([HsDecl], TypeEnv)+tiImpls [] = return ([],Map.empty)+tiImpls bs = withContext (locSimple (srcLoc bs) ("in the recursive implicitly typed: " ++ (show (map getDeclName bs)))) $ do+    let names = map getDeclName bs+    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** tiimpls " ++ show names+    ts <- sequence [newMetaVar Tau kindStar | _ <- bs]+    (res,ps) <- listenPreds $+        local (tcRecursiveCalls_u (Set.union $ Set.fromList names)) $+            localEnv (Map.fromList [  (d,s) | d <- names | s <- ts]) $+                sequence [ tcDecl d s | d <- bs | s <- ts ]+    ps' <- flattenType ps+    ts' <- flattenType ts+    fs <- freeMetaVarsEnv+    let vss = map (Set.fromList . freeVars) ts'+        gs = (Set.unions vss) Set.\\ fs+    (mvs,ds,rs) <- splitReduce fs (foldr1 Set.intersection vss) ps'+    addPreds ds+    mr <- flagOpt FO.MonomorphismRestriction+    scs' <- if restricted mr bs then do+        let gs' = gs Set.\\ Set.fromList (freeVars rs)+        addPreds rs+        quantify_n (Set.toList gs') [] ts'+     else do+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** tiimpls quantify " ++ show (gs,rs,ts')+        quantify_n (Set.toList gs) rs ts'+    let f n s = do+        let (TForAll vs _) = toSigma s+        addCoerce n (ctAbs vs)+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s+        return (n,s)+    nenv <- sequence [ f (getDeclName d) t  | (d,_) <- res | t <- scs' ]+    addToCollectedEnv (Map.fromList nenv)+    return (fsts res, Map.fromList nenv)++tcRhs :: HsRhs -> Sigma -> Tc HsRhs+tcRhs rhs typ = case rhs of+    HsUnGuardedRhs e -> do+        e' <- tcExpr e typ+        return (HsUnGuardedRhs e')+    HsGuardedRhss as -> do+        gas <- mapM (tcGuardedRhs typ) as+        return (HsGuardedRhss gas)++tcMiscDecl d = withContext (locMsg (srcLoc d) "in the declaration" "") $ f d where+    f spec@HsPragmaSpecialize { hsDeclSrcLoc = sloc, hsDeclName = n, hsDeclType = t } = do+        withContext (locMsg sloc "in the SPECIALIZE pragma" $ show n) ans where+        ans = do+            kt <- getKindEnv+            t <- hsTypeToType kt t+            let nn = toName Val n+            sc <- lookupName nn+            listenPreds $ sc `subsumes` t+            addRule RuleSpec { ruleUniq = hsDeclUniq spec, ruleName = nn, ruleType = t, ruleSuper = hsDeclBool spec }+            return [spec]+    f HsInstDecl { .. } = do+	tcClassHead hsDeclClassHead+        ch <- getClassHierarchy+        let as = asksClassRecord ch (hsClassHead hsDeclClassHead) classAssumps+	forM_ hsDeclDecls $ \d -> do+	    case maybeGetDeclName d of+		Just n -> when (n `notElem` fsts as) $ do+		    addWarn InvalidDecl $ printf "Cannot declare '%s' in instance because it is not a method of class '%s'" (show n) (show $ hsClassHead hsDeclClassHead)+		Nothing -> return ()+	return []++    f i@HsDeclDeriving {} = tcClassHead (hsDeclClassHead i)+    f (HsPragmaRules rs) = do+        rs' <- mapM tcRule rs+        return [HsPragmaRules rs']+    f fd@(HsForeignDecl _ _ n qt) = do+        kt <- getKindEnv+        s <- hsQualTypeToSigma kt qt+        addToCollectedEnv (Map.singleton (toName Val n) s)+        return []+    f fd@(HsForeignExport _ e n qt) = do+        kt <- getKindEnv+        s <- hsQualTypeToSigma kt qt+        addToCollectedEnv (Map.singleton (ffiExportName e) s)+        return []+    f _ = return []+    tcClassHead cHead@HsClassHead { .. } = do+        ch <- getClassHierarchy+        ke <- getKindEnv+        let supers = asksClassRecord ch hsClassHead classSupers+            (ctx,(_,[a])) = chToClassHead ke cHead+        assertEntailment ctx [ IsIn s a | s <- supers]+        return []+++tcRule prule@HsRule { hsRuleUniq = uniq, hsRuleFreeVars = vs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2, hsRuleSrcLoc = sloc } =+    withContext (locMsg sloc "in the RULES pragma" $ hsRuleString prule) ans where+        ans = do+            vs' <- mapM dv vs+            tr <- newBox kindStar+            let (vs,envs) = unzip vs'+            ch <- getClassHierarchy+            ((e1,rs1),(e2,rs2)) <- localEnv (mconcat envs) $ do+                    (e1,ps1) <- listenPreds (tcExpr e1 tr)+                    (e2,ps2) <- listenPreds (tcExpr e2 tr)+                    ([],rs1) <- splitPreds ch Set.empty ps1+                    ([],rs2) <- splitPreds ch Set.empty ps2+                    return ((e1,rs1),(e2,rs2))+            mapM_ unBox vs+            vs <- flattenType vs+            tr <- flattenType tr+            let mvs = Set.toList $ Set.unions $ map freeMetaVars (tr:vs)+            nvs <- mapM (newVar . metaKind) mvs+            sequence_ [ varBind mv (TVar v) | v <- nvs |  mv <- mvs ]+            (rs1,rs2) <- flattenType (rs1,rs2)+            ch <- getClassHierarchy+            rs1 <- return $ simplify ch rs1+            rs2 <- return $ simplify ch rs2+            assertEntailment rs1 rs2+            return prule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2 }+        dv (n,Nothing) = do+            v <- newMetaVar Tau kindStar+            let env = (Map.singleton (toName Val n) v)+            addToCollectedEnv env+            return (v,env)+        dv (n,Just t) = do+            kt <- getKindEnv+            tt <- hsTypeToType kt t+            let env = (Map.singleton (toName Val n) tt)+            addToCollectedEnv env+            return (tt,env)++tcDecl ::  HsDecl -> Sigma -> Tc (HsDecl,TypeEnv)++tcDecl decl@(HsActionDecl srcLoc pat@(HsPVar v) exp) typ = withContext (declDiagnostic decl) $ do+    typ <- evalType typ+    (pat',env) <- tcPat pat typ+    let tio = TCon (Tycon tc_IO (Kfun kindStar kindStar))+    e' <- tcExpr exp (TAp tio typ)+    return (decl { hsDeclPat = pat', hsDeclExp = e' }, Map.singleton (toName Val v) typ)++tcDecl decl@(HsPatBind sloc (HsPVar v) rhs wheres) typ = withContext (declDiagnostic decl) $ do+    typ <- evalType typ+    mainFunc <- nameOfMainFunc+    when ( v == mainFunc ) $ do+       tMain <- typeOfMainFunc+       typ `subsumes` tMain+       return ()+    (wheres', env) <- tcWheres wheres+    localEnv env $ do+    case rhs of+        HsUnGuardedRhs e -> do+            e' <- tcExpr e typ+            return (HsPatBind sloc (HsPVar v) (HsUnGuardedRhs e') wheres', Map.singleton (toName Val v) typ)+        HsGuardedRhss as -> do+            gas <- mapM (tcGuardedRhs typ) as+            return (HsPatBind sloc (HsPVar v) (HsGuardedRhss gas) wheres', Map.singleton (toName Val v) typ)++tcDecl decl@(HsFunBind matches) typ = withContext (declDiagnostic decl) $ do+    typ <- evalType typ+    matches' <- mapM (`tcMatch` typ) matches+    return (HsFunBind matches', Map.singleton (getDeclName decl) typ)++tcDecl _ _ = error "Main.tcDecl: bad."++tcMatch ::  HsMatch -> Sigma -> Tc HsMatch+tcMatch (HsMatch sloc funName pats rhs wheres) typ = withContext (locMsg sloc "in" $ show funName) $ do+    let lam (p:ps) (TMetaVar mv) rs = do -- ABS2+            withMetaVars mv [kindArg,kindFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) (a `fn` b) rs+        lam (p:ps) ty@(TArrow s1' s2') rs = do -- ABS1+            (p',env) <- tcPat p s1'+            localEnv env $ do+                s2' <- evalType s2'+                lamPoly ps s2' (p':rs)+        lam [] typ rs = do+            (wheres', env) <- tcWheres wheres+            rhs <- localEnv env $ tcRhs rhs typ+            return (HsMatch sloc funName (reverse rs) rhs wheres')+        lam _ t _ = do+            t <- flattenType t+            fail $ "expected a -> b, found: " ++ prettyPrintType t+        lamPoly ps s@TMetaVar {} rs = lam ps s rs+        lamPoly ps s rs = do+            (_,_,s) <- skolomize s+            lam ps s rs+    typ <- evalType typ+    res <- lam pats typ []+    return res++typeOfMainFunc :: Tc Type+typeOfMainFunc = do+    a <- newMetaVar Tau kindStar+    -- a <- newMetaVar Tau kindStar+    -- a <- Tvar `fmap` newVar kindStar+    return $ tAp (TCon (Tycon tc_IO (Kfun kindStar kindStar))) a++nameOfMainFunc :: Tc Name+nameOfMainFunc = fmap (parseName Val . maybe "Main.main" snd . optMainFunc) getOptions++declDiagnostic ::  (HsDecl) -> Diagnostic+declDiagnostic decl@(HsPatBind sloc (HsPVar {}) _ _) = locMsg sloc "in the declaration" $ render $ ppHsDecl decl+declDiagnostic decl@(HsPatBind sloc pat _ _) = locMsg sloc "in the pattern binding" $ render $ ppHsDecl decl+declDiagnostic decl@(HsFunBind matches) = locMsg (srcLoc decl) "in the function binding" $ render $ ppHsDecl decl+declDiagnostic _ = error "Main.declDiagnostic: bad."++tiExpl ::  Expl -> Tc (HsDecl,TypeEnv)+tiExpl (sc, decl@HsForeignDecl {}) = do return (decl,Map.empty)+tiExpl (sc, decl@HsForeignExport {}) = do return (decl,Map.empty)+tiExpl (sc, decl) = withContext (locSimple (srcLoc decl) ("in the explicitly typed " ++  (render $ ppHsDecl decl))) $ do+    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "** typing expl: " ++ show (getDeclName decl) ++ " " ++ prettyPrintType sc+    sc <- evalFullType sc+    (vs,qs,typ) <- skolomize sc+    let sc' = (tForAll vs (qs :=> typ))+        mp = (Map.singleton (getDeclName decl) sc')+    addCoerce (getDeclName decl) (ctAbs vs)+    addToCollectedEnv mp+    (ret,ps) <- localEnv mp $ listenPreds (tcDecl decl typ)+    ps <- flattenType ps+    ch <- getClassHierarchy+    env <- freeMetaVarsEnv+    (_,ds,rs) <- splitReduce env (freeMetaVarsPreds qs) ps+    printRule $ "endtiExpl: " <+> show env <+> show ps <+> show qs <+> show ds <+> show rs+    addPreds ds+    assertEntailment qs rs+    return ret++restricted :: Bool -> [HsDecl] -> Bool+restricted monomorphismRestriction bs = any isHsActionDecl bs || (monomorphismRestriction && any isSimpleDecl bs) where+   isSimpleDecl :: (HsDecl) -> Bool+   isSimpleDecl (HsPatBind _sloc _pat _rhs _wheres) = True+   isSimpleDecl _ = False++--getBindGroupName (expl,impls) =  map getDeclName (snds expl ++ concat (rights impls) ++ lefts impls)++tiProgram ::  [BindGroup] -> [HsDecl] -> Tc [HsDecl]+tiProgram bgs es = ans where+    ans = do+        let (pr,is) = progressStep (progressNew (length bgs + 1) 45) '.'+        wdump FD.Progress $ liftIO $ do hPutStr stderr ("(" ++ is)+        (r,ps) <- listenPreds $ f pr bgs []+        ps <- flattenType ps+--        ch <- getClassHierarchy+    --    ([],rs) <- splitPreds ch Set.empty ps+        (_,[],rs) <- splitReduce Set.empty Set.empty ps+        topDefaults rs+        return r+    f pr (bg:bgs) rs  = do+        (ds,env) <- (tcBindGroup bg)+        let (pr',os) = progressStep pr '.'+        wdump FD.Progress $ liftIO $ do hPutStr stderr os+        localEnv env $ f pr' bgs (ds ++ rs)+    f _ [] rs = do+        ch <- getClassHierarchy+        pdecls <- mapM tcMiscDecl es+        wdump FD.Progress $ liftIO $ do hPutStr stderr ")\n"+        return (rs ++ concat pdecls)++-- Typing Literals++tiLit :: HsLiteral -> Tc Tau+tiLit (HsChar _) = return tChar+tiLit (HsCharPrim _) = return tCharzh+tiLit (HsInt _) = do+    v <- newVar kindStar+    return $ TForAll [v] ([IsIn class_Num (TVar v)] :=> TVar v)+    --(v) <- newBox Star+    --addPreds [IsIn class_Num v]+    --return v++tiLit (HsFrac _) = do+    v <- newVar kindStar+    return $ TForAll [v] ([IsIn class_Fractional (TVar v)] :=> TVar v)+    --    (v) <- newBox Star+    --    addPreds [IsIn class_Fractional v]+    --    return v++tiLit (HsStringPrim _)  = return (TCon (Tycon tc_BitsPtr kindHash))+tiLit (HsString _)  = return tString+tiLit _ = error "Main.tiLit: bad."++------------------------------------------+-- Binding analysis and program generation+------------------------------------------++-- create a Program structure from a list of decls and+-- type sigs. Type sigs are associated with corresponding+-- decls if they exist++getFunDeclsBg :: TypeEnv -> [HsDecl] -> [BindGroup]+getFunDeclsBg sigEnv decls = makeProgram sigEnv equationGroups where+   equationGroups :: [[HsDecl]]+   equationGroups = getBindGroups bindDecls (nameName . getDeclName) getDeclDeps+   bindDecls = collectBindDecls decls++getBindGroups :: Ord name =>+                 [node]           ->    -- List of nodes+                 (node -> name)   ->    -- Function to convert nodes to a unique name+                 (node -> [name]) ->    -- Function to return dependencies of this node+                 [[node]]               -- Bindgroups++getBindGroups ns fn fd = map f $ stronglyConnComp [ (n, fn n, fd n) | n <- ns] where+    f (AcyclicSCC x) = [x]+    f (CyclicSCC xs) = xs++-- | make a program from a set of binding groups+makeProgram :: TypeEnv -> [[HsDecl]] -> [BindGroup]+makeProgram sigEnv groups = map (makeBindGroup sigEnv ) groups++-- | reunite decls with their signatures, if ever they had one++makeBindGroup :: TypeEnv -> [HsDecl] -> BindGroup+makeBindGroup sigEnv decls = (exps, f impls) where+    (exps, impls) = makeBindGroup' sigEnv decls+    enames = map (nameName . getDeclName . snd) exps+    f xs = map g $ stronglyConnComp [ (x, nameName $ getDeclName x,[ d | d <- getDeclDeps x, d `notElem` enames]) |  x <- xs]+    g (AcyclicSCC x) = Left x+    g (CyclicSCC xs) = Right xs++makeBindGroup' _ [] = ([], [])+makeBindGroup' sigEnv (d:ds) = case Map.lookup funName sigEnv of+        Nothing -> (restExpls, d:restImpls)+        Just scheme -> ((scheme, d):restExpls, restImpls)+   where+   funName = getDeclName d+   (restExpls, restImpls) = makeBindGroup' sigEnv ds++collectBindDecls :: [HsDecl] ->  [HsDecl]+collectBindDecls = filter isBindDecl where+    isBindDecl :: HsDecl -> Bool+    isBindDecl HsActionDecl {} = True+    isBindDecl HsPatBind {} = True+    isBindDecl HsFunBind {} = True+    isBindDecl _ = False
+ src/FrontEnd/Tc/Module.hs view
@@ -0,0 +1,296 @@+module FrontEnd.Tc.Module (tiModules,TiData(..)) where++import Control.Monad.Writer+import Data.Char+import Text.PrettyPrint.HughesPJ as PPrint+import qualified Data.Foldable as T+import qualified Data.Map as Map+import qualified Data.Set as Set++import DataConstructors+import DerivingDrift.Drift+import Doc.PPrint as PPrint+import FrontEnd.Class+import FrontEnd.DataConsAssump     (dataConsEnv)+import FrontEnd.DeclsDepends       (getDeclDeps, debugDeclBindGroups)+import FrontEnd.DependAnalysis     (getBindGroups)+import FrontEnd.Exports+import FrontEnd.HsSyn+import FrontEnd.Infix+import FrontEnd.KindInfer+import FrontEnd.Rename+import FrontEnd.Tc.Main+import FrontEnd.Tc.Monad+import FrontEnd.Tc.Type+import FrontEnd.TypeSigs           (collectSigs, listSigsToSigEnv)+import FrontEnd.TypeSynonyms+import FrontEnd.TypeSyns+import FrontEnd.Utils+import FrontEnd.Warning+import Ho.Type+import Info.Types+import Name.Name as Name+import Name.Names+import Options+import Util.Gen+import Util.Inst()+import Util.SetLike+import qualified FlagDump as FD+import qualified FrontEnd.HsPretty as HsPretty++trimEnv env = Map.filterWithKey (\k _ -> isGlobal k) env++getDeclNames ::  HsDecl -> [Name]+getDeclNames (HsTypeSig _ ns _ ) =  map (toName Val) ns+getDeclNames d = maybeGetDeclName d++-- Extra data produced by the front end, used to fill in the Ho file.+data TiData = TiData {+    tiDataDecls      :: [HsDecl],+    tiDataModules    :: [(Module,HsModule)],+    tiModuleOptions  :: [(Module,Opt)],+    tiCheckedRules   :: [Rule],+    tiCoerce         :: Map.Map Name CoerceTerm,+    tiProps          :: Map.Map Name Properties,+    tiAllAssumptions :: Map.Map Name Type+}++isGlobal x |  (_,(_::String,(h:_))) <- fromName x =  not $ isDigit h+isGlobal _ = error "isGlobal"++buildFieldMap :: [ModInfo] -> FieldMap+buildFieldMap ms = FieldMap ans' ans where+        allDefs = [ (x,z) | (x,_,z) <- concat $ map modInfoDefs ms,+            nameType x == DataConstructor ]+        ans = Map.fromList $ sortGroupUnderFG fst snd $ concat+            [ [ (y,(x,i)) |  y <- ys | i <- [0..] ]  | (x,ys) <-  allDefs ]+        ans' = Map.fromList $ concatMap modInfoConsArity ms++processModule :: FieldMap -> ModInfo -> IO (ModInfo,[Warning])+processModule defs m = do+    when (dump FD.Parsed) $ do+        putStrLn " \n ---- parsed code ---- \n";+        putStrLn $ HsPretty.render+            $ HsPretty.ppHsModule+                $ modInfoHsModule m+    let mod = modInfoHsModule m+    let imp = modInfoImport m+    let (((mod',inst),rmap),errs) = runWriter $ renameModule (modInfoOptions m) defs imp mod+    when (dump FD.Derived && (not $ null inst)) $ do+        putStrLn " \n ---- derived instances ---- \n"+        putStrLn $ HsPretty.render $ HsPretty.ppHsDecls $ inst+    wdump FD.Renamed $ do+        putStrLn " \n ---- renamed code ---- \n"+        putStrLn $ HsPretty.render $ HsPretty.ppHsModule $  mod'+    return (m { modInfoReverseMap = rmap,+                modInfoImport = imp ++ driftResolvedNames,+                modInfoHsModule = mod' }, errs)++-- type check a set of mutually recursive modules.+-- assume all dependencies are met in the+-- ModEnv parameter and export lists have been calculated.++or' :: [(a -> Bool)] -> a -> Bool+or' fs x = or [ f x | f <- fs ]++-- Very broad information on a data type.+data DatDesc+    = DatEnum [Name]+    | DatMany [(Name,Int)]+    | DatNewT Name++getDataDesc :: Monad m => HsDecl -> m (Name,DatDesc)+getDataDesc d = g d where+    g desc = do+        r <- f d+        return (hsDeclName desc,r)+    f HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclCons = (hsConDeclName . head -> cn)  } = return $ DatNewT cn+    f HsDataDecl { hsDeclCons = cs }+        | all null $ map hsConDeclArgs cs = return $ DatEnum (map hsConDeclName cs)+    f HsDataDecl { hsDeclCons = cs } = return $+        DatMany [ (hsConDeclName c, (length . hsConDeclArgs) c) | c <- cs]+    f _ = fail "getDataDesc: not a data declaration"++{-# NOINLINE tiModules #-}+tiModules ::  HoTcInfo -> [ModInfo] -> IO (HoTcInfo,TiData)+tiModules htc ms = do+    let importClassHierarchy = hoClassHierarchy htc+        importKindEnv = hoKinds htc+    let nfm = buildFieldMap ms `mappend` hoFieldMap htc+    mserrs <- mapM (processModule nfm) ms+    processErrors (concatMap snd mserrs)+    let ms = fsts mserrs+    let thisFixityMap = buildFixityMap . concat $+            [filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]+    let fixityMap = thisFixityMap  `mappend` hoFixities htc+    thisTypeSynonyms <- declsToTypeSynonyms (hoTypeSynonyms htc) $ concat+        [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]+    let ts = thisTypeSynonyms `mappend` hoTypeSynonyms htc+    let f x = expandTypeSyns ts (modInfoHsModule x) >>=+            return . FrontEnd.Infix.infixHsModule fixityMap >>=+            \z -> return x { modInfoHsModule = z }+    ms <- mapM f ms+    processIOErrors+    let ds = concat [ hsModuleDecls $ modInfoHsModule m | m <- ms ]++    wdump FD.Decls $ do+        putStrLn "  ---- processed decls ---- "+        putStrLn $ HsPretty.render (HsPretty.ppHsDecls ds)++    -- kind inference for all type constructors type variables and classes in the module+    let classAndDataDecls = filter (or' [isHsDataDecl, isHsClassDecl, isHsClassAliasDecl]) ds+    kindInfo <- kiDecls importKindEnv ds -- classAndDataDecls++    when (dump FD.Kind) $+         do {putStrLn " \n ---- kind information ---- \n";+             putStrLn $ PPrint.render $ pprint kindInfo}++    processIOErrors++    let localDConsEnv = dataConsEnv kindInfo classAndDataDecls+    wdump FD.Dcons $ do+        putStr "\n ---- data constructor assumptions ---- \n"+        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |+            (n,s) <- Map.toList localDConsEnv]++    cHierarchy <- makeClassHierarchy importClassHierarchy kindInfo ds+    let smallClassHierarchy = foldr addInstanceToHierarchy cHierarchy dinsts where+            derivingClauses = collectDeriving ds+            dataInfo = Map.fromList $ concatMap getDataDesc ds+            dinsts = concatMap g derivingClauses where+                g r@(_,c,t) | c `elem` enumDerivableClasses,+                    Just (DatEnum (_:_:_)) <- Map.lookup t dataInfo = [f r]+                            | c `elem` enumDerivableClasses,+                    t `elem` [tc_Bool, tc_Ordering, tc_IOErrorType, tc_IOMode] = [f r]+                --g r@(_,c,t) | c `notElem` noNewtypeDerivable, Just (DatMany True [_]) <- Map.lookup t dataInfo = [f r]+                g _ = []+                f (sl,c,t) = emptyInstance {+                    instSrcLoc = sl,+                    instDerived = True,+                    instHead = [] :=> IsIn c (TCon (Tycon t kindStar))+                    }+    smallClassHierarchy <- checkForDuplicateInstaces importClassHierarchy smallClassHierarchy++    let cHierarchyWithInstances = scatterAliasInstances $+            smallClassHierarchy `mappend` importClassHierarchy++    when (dump FD.ClassSummary) $ do+        putStrLn "  ---- class summary ---- "+        printClassSummary cHierarchyWithInstances+    when (dump FD.Class) $+         do {putStrLn "  ---- class hierarchy ---- ";+             printClassHierarchy smallClassHierarchy}+    -- lift the instance methods up to top-level decls+    let cDefBinds = concat [ [ z | z <- ds] | HsClassDecl _ _ ds <- ds]+    let myClassAssumps = concat [ classAssumps as | as <- classRecords cHierarchyWithInstances ]+        instanceEnv = Map.fromList instAssumps+        classDefs = snub (concatMap getDeclNames cDefBinds)+        classEnv = Map.fromList $ [ (x,y) | (x,y) <- myClassAssumps, x `elem` classDefs  ]+        (liftedInstances,instAssumps) = mconcatMap+            (instanceToTopDecls kindInfo cHierarchyWithInstances) ds++    when (not (null liftedInstances) && (dump FD.Instance) ) $ do+        putStrLn "  ---- lifted instance declarations ---- "+        putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) liftedInstances+        putStrLn $ PPrint.render $ pprintEnvMap instanceEnv++    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl, isHsActionDecl] d]+    let rTySigs =  [ d | d <- ds, or' [isHsTypeSig] d]++    -- build an environment of assumptions for all the type signatures+    let allTypeSigs = collectSigs (funPatBinds ++ liftedInstances) ++ rTySigs++    when (dump FD.Srcsigs) $+         do {putStrLn " ---- type signatures from source code (after renaming) ---- ";+             putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) allTypeSigs}++    let sigEnv = Map.unions [listSigsToSigEnv kindInfo allTypeSigs,instanceEnv, classEnv]+    when (dump FD.Sigenv) $+         do {putStrLn "  ---- initial sigEnv information ---- ";+             putStrLn $ PPrint.render $ pprintEnvMap sigEnv}+    let bindings = (funPatBinds ++  liftedInstances)+        --classDefaults  = snub [ getDeclName z | z <- cDefBinds, isHsFunBind z || isHsPatBind z ]+        classNoDefaults = snub (concat [ getDeclNames z | z <- cDefBinds ]) -- List.\\ classDefaults+        noDefaultSigs = Map.fromList [ (n,maybe (error $ "sigEnv:"  ++ show n) id $ Map.lookup n sigEnv) | n <- classNoDefaults ]+    --when verbose2 $ putStrLn (show bindings)+    let programBgs = getBindGroups bindings (nameName . getDeclName) getDeclDeps++    when (dump FD.Bindgroups) $+         do {putStrLn " \n ---- toplevel variable binding groups ---- ";+             putStrLn " ---- Bindgroup # = [members] [vars depended on] [missing vars] ---- \n";+             putStr $ debugDeclBindGroups programBgs}++    let program = makeProgram sigEnv programBgs+    when (dump FD.Program) $ do+        putStrLn " ---- Program ---- "+        mapM_ putStrLn $ map (PPrint.render . PPrint.pprint) $  program++    when (dump FD.AllTypes) $ do+        putStrLn "  ---- all types ---- "+        putStrLn $ PPrint.render $ pprintEnvMap+            (sigEnv `mappend` localDConsEnv `mappend` hoAssumps htc)++    let moduleName = modInfoName tms+        (tms:_) = ms+    let tcInfo = tcInfoEmpty {+        tcInfoEnv = hoAssumps htc `mappend` localDConsEnv,+        tcInfoSigEnv = sigEnv,+        tcInfoModName = moduleName,+        tcInfoKindInfo = kindInfo,+        tcInfoClassHierarchy = cHierarchyWithInstances+        }++    (localVarEnv,checkedRules,coercions,tcDs) <- withOptionsT (modInfoOptions tms) $ runTc tcInfo $ do+        --mapM_ addWarning (concatMap snd mserrs)+        (tcDs,out) <- listen (tiProgram program ds)+        env <- getCollectedEnv+        cc <- getCollectedCoerce+        let cc' = Map.union cc $ Map.fromList [ (as,lup v) | (as,v) <- outKnots out ]+            lup v = case Map.lookup v cc of+                Just (CTAbs xs) -> ctAp (map TVar xs)+                _ -> ctId+        return (env,T.toList $ checkedRules out,cc',tcDs)++    when (dump FD.Decls) $ do+        putStrLn " \n ---- typechecked code ---- \n"+        mapM_ (putStrLn . HsPretty.render . HsPretty.ppHsDecl) tcDs++    when (dump FD.Types) $ do+        putStrLn " ---- the types of identifiers ---- "+        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |+            (n,s) <- Map.toList (if verbose2 then localVarEnv else trimEnv localVarEnv)]+    when (dump FD.Types) $ do+        putStrLn " ---- the coersions of identifiers ---- "+        mapM_ putStrLn [ show n ++  " --> " ++ show s |  (n,s) <- Map.toList coercions]++    localVarEnv <- return $  localVarEnv `Map.union` noDefaultSigs++    let pragmaProps = fromList $ Map.toList $ Map.fromListWith mappend+            [(toName Name.Val x,fromList $ readProp w) | HsPragmaProps _ w xs <- ds, x <- xs]++    let allAssumps = localDConsEnv `Map.union` localVarEnv+        allExports = Set.fromList (concatMap modInfoExport ms)+        externalKindEnv = restrictKindEnv (\ x  -> isGlobal x && (getModule x `elem` map (Just . modInfoName) ms)) kindInfo+    let hoEx = HoTcInfo {+            hoExports = Map.fromList [ (modInfoName m,modInfoExport m) | m <- ms ],+            hoDefs =  Map.fromList [ (x,(y,filter (`member` allExports) z)) | (x,y,z) <- concat $ map modInfoDefs ms, x `member` allExports],+            hoAssumps = Map.filterWithKey (\k _ -> k `member` allExports) allAssumps,+            hoFixities = restrictFixityMap (`member` allExports) thisFixityMap,+            -- TODO - this contains unexported names, we should filter these before writing to disk.+            --hoKinds = restrictKindEnv (`member` allExports) kindInfo,+            hoKinds = externalKindEnv,+            hoClassHierarchy = smallClassHierarchy,+            hoFieldMap = buildFieldMap ms,+            hoTypeSynonyms = restrictTypeSynonyms (`member` allExports) thisTypeSynonyms+        }+        tiData = TiData {+            tiDataDecls = tcDs ++ filter isHsClassDecl ds,+            tiDataModules = [ (modInfoName m, modInfoHsModule m) |  m <- ms],+            tiModuleOptions = [ (modInfoName m, modInfoOptions m) |  m <- ms],+            tiCheckedRules = checkedRules,+            tiCoerce       = coercions,+            tiProps        = pragmaProps,+            tiAllAssumptions = allAssumps+        }+    processIOErrors+    return (hoEx,tiData)
+ src/FrontEnd/Tc/Type.hs view
@@ -0,0 +1,333 @@+module FrontEnd.Tc.Type(+    Kind(..),+    KBase(..),+    MetaVar(..),+    MetaVarType(..),+    Pred(..),+    Preds(),+    Qual(..),+    Tycon(..),+    Type(..),+    Tyvar(..),+    kindStar,+    kindFunRet,+    kindUTuple,+    unfoldKind,+    fn,+    fromTAp,+    fromTArrow,+    module FrontEnd.Tc.Type,+    prettyPrintType,+    tForAll,+    tList,+    Constraint(..),+    Class(),+    Kindvar(..),+    tTTuple,+    tTTuple',+    tAp,+    tArrow,+    tyvar+    ) where++import Control.Monad.Identity+import Control.Monad.Writer+import Data.IORef+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as S++import Doc.DocLike+import Doc.PPrint+import FrontEnd.Representation+import FrontEnd.SrcLoc+import FrontEnd.Tc.Kind+import Name.Name+import Name.Names+import Support.FreeVars+import Support.Tickle++type Sigma' = Sigma+type Tau' = Tau+type Rho' = Rho+type Sigma = Type+type Rho = Type+type Tau = Type++type SkolemTV = Tyvar+type BoundTV = Tyvar++type Preds = [Pred]++data Constraint = Equality {+    constraintSrcLoc :: SrcLoc,+    constraintType1  :: Type,+    constraintType2  :: Type+    }++instance HasLocation Constraint where+    srcLoc Equality { constraintSrcLoc = sl } = sl++applyTyvarMap :: [(Tyvar,Type)] -> Type -> Type+applyTyvarMap ts t = f initMp t where+    initMp = Map.fromList [ (tyvarName v,t) | (v,t) <- ts ]+    -- XXX name capture!+    f mp (TForAll as qt) = TForAll as (fq (foldr Map.delete mp (map tyvarName as)) qt)+    f mp (TExists as qt) = TExists as (fq (foldr Map.delete mp (map tyvarName as)) qt)+    f mp (TVar tv) = case Map.lookup (tyvarName tv) mp of+            Just t'  -> t'+            Nothing -> (TVar tv)+    f mp t = tickle (f mp) t+    fq mp (ps :=> t) = map (tickle (f mp)) ps :=> f mp t++applyTyvarMapQT :: [(Tyvar,Type)] -> Qual Type -> Qual Type+applyTyvarMapQT ts qt = qt' where+    (TForAll [] qt') = applyTyvarMap ts (TForAll [] qt)++typeOfType :: Type -> (MetaVarType,Bool)+typeOfType TForAll { typeArgs = as, typeBody = _ :=> t } = (Sigma,isBoxy t)+typeOfType t | isTau' t = (Tau,isBoxy t)+typeOfType t = (Rho,isBoxy t)++fromType :: Sigma -> ([Tyvar],[Pred],Type)+fromType s = case s of+    TForAll as (ps :=> r) -> (as,ps,r)+    r -> ([],[],r)++isTau :: Type -> Bool+isTau TForAll {} = False+isTau (TMetaVar MetaVar { metaType = t })+    | t == Tau = True+    | otherwise = False+isTau t = getAll $ tickleCollect (All . isTau) t++isTau' :: Type -> Bool+isTau' TForAll {} = False+isTau' t = getAll $ tickleCollect (All . isTau') t++isBoxy :: Type -> Bool+isBoxy (TMetaVar MetaVar { metaType = t }) | t > Tau = True+isBoxy t = getAny $ tickleCollect (Any . isBoxy) t++isRho' :: Type -> Bool+isRho' TForAll {} = False+isRho' _ = True++isRho :: Type -> Bool+isRho r = isRho' r && not (isBoxy r)++isBoxyMetaVar :: MetaVar -> Bool+isBoxyMetaVar MetaVar { metaType = t } = t > Tau++extractTyVar ::  Monad m => Type -> m Tyvar+extractTyVar (TVar tv) = return tv+extractTyVar t = fail $ "not a Var:" ++ show t++extractMetaVar :: Monad m => Type -> m MetaVar+extractMetaVar (TMetaVar t)  = return t+extractMetaVar t = fail $ "not a metaTyVar:" ++ show t++extractBox :: Monad m => Type -> m MetaVar+extractBox (TMetaVar mv) | metaType mv > Tau  = return mv+extractBox t = fail $ "not a metaTyVar:" ++ show t++newtype UnVarOpt = UnVarOpt {+    failEmptyMetaVar :: Bool+    }++{-# SPECIALIZE flattenType :: MonadIO m => Type -> m Type #-}+flattenType :: (MonadIO m, UnVar t) => t -> m t+flattenType t = liftIO $ unVar' t++class UnVar t where+    unVar' ::   t -> IO t++instance UnVar t => UnVar [t] where+   unVar' xs = mapM unVar' xs++instance UnVar Pred where+    unVar' (IsIn c t) = IsIn c `liftM` unVar' t+    unVar' (IsEq t1 t2) = liftM2 IsEq (unVar' t1) (unVar' t2)++instance (UnVar a,UnVar b) => UnVar (a,b) where+    unVar' (a,b) = do+        a <- unVar' a+        b <- unVar' b+        return (a,b)++instance UnVar t => UnVar (Qual t) where+    unVar' (ps :=> t) = liftM2 (:=>) (unVar' ps) (unVar' t)++instance UnVar Type where+    unVar' tv =  do+        let ft (TForAll vs qt) = do+                qt' <- unVar' qt+                return $ TForAll vs qt'+            ft (TExists vs qt) = do+                qt' <- unVar' qt+                return $ TExists vs qt'+            ft (TAp (TAp (TCon arr) a1) a2) | tyconName arr == tc_Arrow = ft (TArrow a1 a2)+            ft t@(TMetaVar _) = return t+            ft t = tickleM (unVar' . (id :: Type -> Type)) t+        tv' <- findType tv+        ft tv'++followTaus :: MonadIO m => Type -> m Type+followTaus tv@(TMetaVar mv@MetaVar {metaRef = r }) | not (isBoxyMetaVar mv) = liftIO $ do+    rt <- readIORef r+    case rt of+        Nothing -> return tv+        Just t -> do+            t' <- followTaus t+            writeIORef r (Just t')+            return t'+followTaus tv = return tv++findType :: MonadIO m => Type -> m Type+findType tv@(TMetaVar MetaVar {metaRef = r }) = liftIO $ do+    rt <- readIORef r+    case rt of+        Nothing -> return tv+        Just t -> do+            t' <- findType t+            writeIORef r (Just t')+            return t'+findType tv = return tv++readMetaVar :: MonadIO m => MetaVar -> m (Maybe Type)+readMetaVar MetaVar { metaRef = r }  = liftIO $ do+    rt <- readIORef r+    case rt of+        Nothing -> return Nothing+        Just t -> do+            t' <- findType t+            writeIORef r (Just t')+            return (Just t')++{-+freeMetaVars :: Type -> S.Set MetaVar+freeMetaVars (TMetaVar mv) = S.singleton mv+freeMetaVars t = tickleCollect freeMetaVars t+freeMetaVars :: Type -> S.Set MetaVar+freeMetaVars t = worker t S.empty+    where worker :: Type -> (S.Set MetaVar -> S.Set MetaVar)+          worker (TMetaVar mv) = S.insert mv+          worker (TAp l r) = worker l . worker r+          worker (TArrow l r) = worker l . worker r+          worker (TAssoc c cas eas) = foldr (.) id (map worker cas) . foldr (.) id (map worker eas)+          worker (TForAll ta (ps :=> t)) = foldr (.) id (map worker2 ps) . worker t+          worker (TExists ta (ps :=> t)) = foldr (.) id (map worker2 ps) . worker t+          worker _ = id+          worker2 :: Pred -> (S.Set MetaVar -> S.Set MetaVar)+          worker2 (IsIn c t) = worker t+          worker2 (IsEq t1 t2) = worker t1 . worker t2+-}++freeMetaVars :: Type -> S.Set MetaVar+freeMetaVars t = f t where+    f (TMetaVar mv) = S.singleton mv+    f (TAp l r) = f l `S.union` f r+    f (TArrow l r) = f l `S.union` f r+    f (TAssoc c cas eas) = S.unions (map f cas ++ map f eas)+    f (TForAll ta (ps :=> t)) = S.unions (f t:map f2 ps)+    f (TExists ta (ps :=> t)) = S.unions (f t:map f2 ps)+    f _ = S.empty+    f2 (IsIn c t) = f t+    f2 (IsEq t1 t2) = f t1 `S.union` f t2++instance FreeVars Type [Tyvar] where+    freeVars (TVar u)      = [u]+    freeVars (TForAll vs qt) = freeVars qt Data.List.\\ vs+    freeVars (TExists vs qt) = freeVars qt Data.List.\\ vs+    freeVars t = foldr union [] $ tickleCollect ((:[]) . (freeVars :: Type -> [Tyvar])) t++instance FreeVars Type [MetaVar] where+    freeVars t = S.toList $ freeMetaVars t++instance FreeVars Type (S.Set MetaVar) where+    freeVars t = freeMetaVars t++instance (FreeVars t b,FreeVars Pred b) => FreeVars (Qual t) b where+    freeVars (ps :=> t)  = freeVars t `mappend` freeVars ps++instance FreeVars Type b =>  FreeVars Pred b where+    freeVars (IsIn _c t)  = freeVars t+    freeVars (IsEq t1 t2)  = freeVars (t1,t2)++instance Tickleable Type Pred where+    tickleM f (IsIn c t) = liftM (IsIn c) (f t)+    tickleM f (IsEq t1 t2) = liftM2 IsEq (f t1) (f t2)++instance Tickleable Type Type where+    tickleM f (TAp l r) = liftM2 tAp (f l) (f r)+    tickleM f (TArrow l r) = liftM2 TArrow (f l) (f r)+    tickleM f (TAssoc c cas eas) = liftM2 (TAssoc c) (mapM f cas) (mapM f eas)+    tickleM f (TForAll ta (ps :=> t)) = do+        ps <- mapM (tickleM f) ps+        liftM (TForAll ta . (ps :=>)) (f t)+    tickleM f (TExists ta (ps :=> t)) = do+        ps <- mapM (tickleM f) ps+        liftM (TExists ta . (ps :=>)) (f t)+    tickleM _ t = return t++data Rule = RuleSpec {+    ruleUniq :: (Module,Int),+    ruleName :: Name,+    ruleSuper :: Bool,+    ruleType :: Type+    } |+    RuleUser {+    ruleUniq :: (Module,Int),+    ruleFreeTVars :: [(Name,Kind)]+    }++-- CTFun f => \g . \y -> f (g y)+data CoerceTerm = CTId | CTAp [Type] | CTAbs [Tyvar] | CTFun CoerceTerm | CTCompose CoerceTerm CoerceTerm++instance Show CoerceTerm where+    showsPrec _ CTId = showString "id"+    showsPrec n (CTAp ts) = ptrans (n > 10) parens $ char '@' <+> hsep (map (parens . prettyPrintType) ts)+    showsPrec n (CTAbs ts) = ptrans (n > 10) parens $ char '\\' <+> hsep (map pprint ts)+    showsPrec n (CTFun ct) = ptrans (n > 10) parens $ text "->" <+> showsPrec 11 ct+    showsPrec n (CTCompose ct1 ct2) = ptrans (n > 10) parens $ (showsPrec 11 ct1) <+> char '.' <+> (showsPrec 11 ct2)++-- | Apply the function if the 'Bool' is 'True'.+ptrans :: Bool -> (a -> a) -> (a -> a)+ptrans b f = if b then f else id++instance Monoid CoerceTerm where+    mempty = CTId+    mappend = composeCoerce++ctFun :: CoerceTerm -> CoerceTerm+ctFun CTId = CTId+ctFun x = CTFun x++ctAbs :: [Tyvar] -> CoerceTerm+ctAbs [] = CTId+ctAbs xs = CTAbs xs++ctAp :: [Type] -> CoerceTerm+ctAp [] = CTId+ctAp xs = CTAp xs++ctId :: CoerceTerm+ctId = CTId++composeCoerce :: CoerceTerm -> CoerceTerm -> CoerceTerm+--composeCoerce (CTFun a) (CTFun b) = ctFun (a `composeCoerce` b)+composeCoerce CTId x = x+composeCoerce x CTId = x+--composeCoerce (CTAbs ts) (CTAbs ts') = CTAbs (ts ++ ts')+--composeCoerce (CTAp ts) (CTAp ts') = CTAp (ts ++ ts')+--composeCoerce (CTAbs ts) (CTAp ts') = f ts ts' where+--    f (t:ts) (TVar t':ts') | t == t' = f ts ts'+--    f [] [] = CTId+--    f _ _ = CTCompose (CTAbs ts) (CTAp ts')+composeCoerce x y = CTCompose x y++instance UnVar Type => UnVar CoerceTerm where+    unVar' (CTAp ts) = CTAp `liftM` unVar' ts+    unVar' (CTFun ct) = CTFun `liftM` unVar' ct+    unVar' (CTCompose c1 c2) = liftM2 CTCompose (unVar' c1) (unVar' c2)+    unVar' x = return x
+ src/FrontEnd/Tc/Unify.hs view
@@ -0,0 +1,312 @@++module FrontEnd.Tc.Unify(+    subsumes,+    boxyMatch,+    printRule,+    listenSolvePreds+    ) where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Writer(Monoid(..))+import qualified Data.Map as Map+import qualified Data.Set as Set++import Doc.DocLike+import Doc.PPrint+import FrontEnd.Tc.Class+import FrontEnd.Tc.Kind+import FrontEnd.Tc.Monad+import FrontEnd.Tc.Type+import Options+import Support.CanType+import Support.FreeVars+import qualified FlagDump as FD++pretty vv = prettyPrintType vv+ppretty vv = parens (pretty vv)++-- | this ensures the first argument is at least as polymorphic as the second+-- actual/offered <= expected+-- actual/offered `subsumes` expected++subsumes :: Sigma' -> Sigma' -> Tc CoerceTerm+subsumes s1 s2 = do+    (s1,s2) <- if dump FD.BoxySteps then do+        s1 <- evalFullType s1+        s2 <- evalFullType s2+        return (s1,s2)+      else do+        s1 <- evalType s1+        s2 <- evalType s2+        return (s1,s2)+    printRule $ "subsumes: " <> ppretty s1 <+> ppretty s2+    sub s1 s2+   where+    -- SBOXY+    sub tb@(TMetaVar mv) b  = do+        boxyMatch tb b+        return ctId++    -- SKOL needs to be after SBOXY+    sub s1 fa@TForAll {} = do+        printRule "SKOL"+        (vs,_,r2) <- skolomize fa+        f <- s1 `subsumes` r2+        return (composeCoerce (ctAbs vs) f)+        --return (CoerceTerm (\x -> CoerceLam vs (f x)))++    -- SPEC+    sub s1@(TForAll as (_ :=> _))  r2 | isRho' r2 = do   -- isRho' r2+        printRule "SPEC"+        (ts,r1') <- boxyInstantiate s1+        f <- r1' `subsumes` r2+        return (f `composeCoerce` (ctAp ts))+        --return (CoerceTerm (\x -> f (CoerceApp x ts)))++    -- CON+    sub s1 s2 | (_,(_:_)) <- fromTAp s1 = do+        s1 `boxyMatch` s2+        return ctId++    -- F1+    sub (TArrow s1 s2) (TArrow s3 s4) = do+        printRule "F1"+        boxyMatch s3 s1+        f2 <- s2 `subsumes` s4+        return (ctFun f2)+        --return (CoerceTerm (\g -> CoerceFn f2 g))+        --return (\g y -> f2 (runCoerce g y))++    -- F2+    sub t@(TArrow s1 s2) (TMetaVar mv) = do+        printRule "F2"+        withMetaVars mv [getType s1, getType s2] (\ [a,b] -> TArrow a b) $ \ [a,b] -> do+        subsumes t (a `fn` b)++    sub t1@TArrow {} t2@TAp {} = boxyMatch t1 t2 >> return ctId++    -- ASSOC+    sub s1@TAssoc {} s2 = do+        printRule "ASSOC-L"+        s1 `boxyMatch` s2+        return ctId+    -- ASSOC+    sub s1 s2@TAssoc {} = do+        printRule "ASSOC-R"+        s1 `boxyMatch` s2+        return ctId++    -- BMONO+    sub a (TMetaVar mv) | isTau a  = varBind mv a >> return ctId+    -- MONO+    sub a b | isTau a && isTau b = unify a b >> return ctId++    sub a b = fail $ "subsumes failure: " <> ppretty a <+> ppretty b++-- might as well return flattened type+-- we can skip the occurs check for boxy types+occursCheck u@MetaVar { metaType = Tau } t = do+    tt <- evalFullType t+    when (u `Set.member` freeMetaVars tt) $ unificationError (TMetaVar u) tt -- occurs check+    return tt+occursCheck u t = return t++printRule :: String -> Tc ()+printRule s+    | dump FD.BoxySteps = liftIO $ putStrLn s+    | otherwise = return ()++boxyMatch :: Sigma' -> Sigma' -> Tc ()+boxyMatch s1 s2 = do+    (s1,s2) <- if dump FD.BoxySteps then do+        s1 <- evalFullType s1+        s2 <- evalFullType s2+        return (s1,s2)+      else do+        s1 <- evalType s1+        s2 <- evalType s2+        return (s1,s2)+    printRule $ "boxyMatch: " <> ppretty s1 <+> ppretty s2+    b <- bm s1 s2+    if b then do+        printRule "SYM"+        printRule $ "boxyMatch: " <> ppretty s2 <+> ppretty s1+        b' <- bm s2 s1+        when b' $  fail $ "boxyMatch failure: " <> ppretty s1 <+> ppretty s2+     else return ()+   where+    bm (TMetaVar v1) (TMetaVar v2) = do+        var_meets_var v1 v2+        return False++    -- AEQ1+    bm a@(TArrow s1 s2) (TMetaVar mv) = do+        printRule "AEQ1"+        occursCheck mv a+        withMetaVars mv [getType s1, getType s2] (\ [t1,t2] -> TArrow t1 t2) $ \ [t1,t2] ->+            boxyMatch s1 t1 >> boxyMatch s2 t2+        return False++    -- AEQ2+    bm (TArrow s1 s2) (TArrow s3 s4) = do+        printRule "AEQ2"+        boxyMatch s1 s3+        boxyMatch s2 s4+        return False++    bm t@(TArrow s1 s2) (TAp (TAp arr a1) a2) = do+        printRule "AF2-arrow"+        tArrow `boxyMatch` arr+        boxyMatch s1 a1+        boxyMatch s2 a2+        return False++    -- CEQ1++    bm a (TMetaVar mv) | (TCon ca,as) <- fromTAp a = do+        printRule $ "CEQ1: " ++ prettyPrintType a+        a <- occursCheck mv a+        withMetaVars mv (map getType as) (\ ts -> foldl tAp (TCon ca) ts) $ \ ts ->+            sequence_ [ boxyMatch a t | t <- ts | a <- as ]+        return False++    bm a (TMetaVar mv) | (x,xs@(_:_)) <- fromTAp a = do+        --printRule $ "CEQ1: " ++ pprint a+        let xxs = x:xs+        a <- occursCheck mv a+        withMetaVars mv (map getType xxs) (\ (t:ts) -> foldl tAp t ts) $ \ ts ->+            sequence_ [ boxyMatch a t | t <- ts | a <- xxs ]+        return False++    -- CEQ2++    bm a b | (TCon ca,as) <- fromTAp a, (TCon cb,bs) <- fromTAp b = case ca == cb of+        False -> unificationError a b+        True | length as == length bs -> do+            printRule $ "CEQ2: " ++ pprint ca+            sequence_ [boxyMatch x y | x <- as | y <- bs] >> return False+        _ -> unificationError a b++    -- SEQ1+    bm a@(TForAll vs (ps :=> tbody)) (TMetaVar mv) = do+        a <- occursCheck mv a+        withMetaVars mv [getType mv] (\ [t] -> TForAll vs (ps :=> t))  $ \ [t] ->+            boxyMatch tbody t+        return False++    -- SEQ2++    bm t1@TForAll {} (TForAll as2 qt2) = do+        TForAll as1 (ps1 :=> r1) <- freshSigma t1+        let (ps2 :=> r2) = inst mempty (Map.fromList [ (tyvarName a2,TVar a1) | a1 <- as1 | a2 <- as2 ]) qt2+        printRule "SEQ2"+        boxyMatch r1 r2+        assertEquivalant ps1 ps2+        return False++    bm (TAp a b) (TAp c d) = do+        printRule "APP"+        a `boxyMatch` c+        b `boxyMatch` d+        return False++    -- Associated type+    bm ta@TAssoc {} (TMetaVar mv) = do+        ta' <- evalFullType ta+        if mv `elem` freeVars ta' then do+            printRule "ASSOC-OCCURS"+            addPreds [IsEq ta' (TMetaVar mv)]+         else do+            printRule "ASSOC-BIND"+            varBind mv ta'+        return False++    bm ta@TAssoc {} tb@TAssoc {} = do+        ta' <- evalFullType ta+        tb' <- evalFullType tb+        when (ta' /= tb') $ do+            printRule "ASSOC-EQ"+            addPreds [IsEq ta' tb']+        return False++    bm ta@TAssoc {} t = do+        printRule "ASSOC-EQ"+        -- are associated types tau?+        addPreds [IsEq ta t]+        return False++    -- MEQ1 MEQ2  SYM+    bm a b+        | isTau a, TMetaVar mv <- b = printRule "MEQ1" >> varBind mv a >> return False+        | isTau a && isTau b = printRule "MEQ2" >> unify a b >> return False+    bm _ _ = return True++solveConstraints :: [Constraint] -> Tc ()+solveConstraints cs = mapM_ f cs where+    f Equality { constraintSrcLoc = _sl, constraintType1 = t1, constraintType2 = t2 } = {- withSrcLoc sl $ -} boxyMatch t1 t2++listenSolvePreds :: Tc a -> Tc (a,[Pred])+listenSolvePreds tc = do+    (x,(ps,cs)) <- listenCPreds tc+    ((),(ps',cs')) <- listenCPreds (solveConstraints cs)+    ch <- getClassHierarchy+    return (x,simplify ch (ps ++ ps') ++ [ IsEq a b | Equality _ a b <- cs' ])++var_meets_var :: MetaVar -> MetaVar -> Tc ()+var_meets_var tv1 tv2 = do+--    when (getType tv1 /= getType tv2) $ error "BBEQ boxyMatch kinds"+    k <- kindCombine (getType tv1) (getType tv2)+    f k tv1 tv2+    where+    f k tv1 tv2 | tv1 == tv2 = zonkKind k tv1 >> return ()+    f k tv1 tv2 | isBoxyMetaVar tv1 && isBoxyMetaVar tv2 = do+            printRule "BBEQ"+            tt <- newMetaVar Tau k+            varBind tv1 tt+            varBind tv2 tt+    f k tv1 tv2 | isBoxyMetaVar tv1  = do+            printRule "BBEQ-L"+            varBind tv1 (TMetaVar tv2)+            zonkKind k tv2+            return ()+    f k tv1 tv2 | isBoxyMetaVar tv2  = do+            printRule "BBEQ-R"+            varBind tv2 (TMetaVar tv1)+            zonkKind k tv1+            return ()+    f k tv1 tv2  = do+            printRule "BBEQ-Tau"+            varBind tv2 (TMetaVar tv1)+            zonkKind k tv1+            return ()++unify      :: Tau -> Tau -> Tc ()+unify t1 t2 = do+    t1' <- evalType t1+    t2' <- evalType t2+    printRule $ "unify: " <> ppretty t1' <+> ppretty t2'+    mgu t1' t2'++mgu (TAp l r) (TAp l' r')+   = do s1 <- unify l l'+        s2 <- unify r r'+        return ()+mgu (TArrow l r) (TArrow l' r')+   = do s1 <- unify l l'+        s2 <- unify r r'+        return ()+mgu (TMetaVar u) t | not $ isBoxyMetaVar u = varBind u t+mgu t (TMetaVar u) | not $ isBoxyMetaVar u = varBind u t+mgu (TVar a) (TVar b) | a == b = return ()+mgu c1@(TCon tc1) c2@(TCon tc2)+           | tc1==tc2 = return ()+           -- | otherwise = fail $ "mgu: Constructors don't match:" ++ show (c1,c2)+           | otherwise = unificationError c1 c2+mgu TForAll {} _ = error "attempt to unify TForall"+mgu _ TForAll {} = error "attempt to unify TForall"+mgu t1 t2  = unificationError t1 t2++-- This is used in pattern matching because it might be polymorphic, but also needs to match exactly+--subsumesPattern a b | isTau b = a `boxyMatch` b+--subsumes
+ src/FrontEnd/TypeSigs.hs view
@@ -0,0 +1,120 @@+{-------------------------------------------------------------------------------++        Copyright:              The Hatchet Team (see file Contributors)+        Module:                 TypeSigs+        Description:            Collects all the type signatures from a module+        Primary Authors:        Bernie Pope, John Meacham+        Notes:                  See the file License for license information++-------------------------------------------------------------------------------}++module FrontEnd.TypeSigs (collectSigs,+                 collectSigEnv,+                 SigEnv,+                 listSigsToSigEnv) where++import Control.Monad.Identity+import Control.Monad.Writer+import qualified Data.Map as Map++import FrontEnd.HsSyn+import FrontEnd.KindInfer+import FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse+import FrontEnd.Tc.Type+import Name.Name++newtype SC a = SC (Writer [HsDecl] a)+    deriving(Monad)++fromSC :: SC () -> [HsDecl]+fromSC (SC m) = execWriter m++addSigs :: [HsDecl] -> SC ()+addSigs ds = SC $ tell ds++instance MonadSrcLoc SC where+instance MonadSetSrcLoc SC where+    withSrcLoc _ a = a++collectSigEnv :: KindEnv -> HsStmt -> SigEnv+collectSigEnv kindInfo stmt = sigEnv where+    allTypeSigs = collectSigsFromStmt stmt+    sigEnv = listSigsToSigEnv kindInfo allTypeSigs++collectSigs :: [(HsDecl)] -> [(HsDecl)]+collectSigs ds = collectSigsFromDecls ds++collectSigsFromDecls :: [(HsDecl)] -> [(HsDecl)]+collectSigsFromDecls [] = []+collectSigsFromDecls (d@(HsTypeSig {}):ds) = d : collectSigsFromDecls ds+collectSigsFromDecls ((HsForeignDecl   sl _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds+collectSigsFromDecls ((HsForeignExport sl _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds+collectSigsFromDecls ((HsPatBind _ _ rhs wheres):ds)+   = collectSigsFromRhs rhs +++     collectSigsFromDecls wheres +++     collectSigsFromDecls ds+collectSigsFromDecls ((HsFunBind matches):ds)+   = concatMap collectSigsFromMatch matches +++     collectSigsFromDecls ds+collectSigsFromDecls (_:ds) = collectSigsFromDecls ds++collectSigsFromMatch :: (HsMatch) -> [(HsDecl)]+collectSigsFromMatch (HsMatch _ _ _ rhs wheres)+   = collectSigsFromRhs rhs +++     collectSigsFromDecls wheres++collectSigsFromRhs :: (HsRhs) -> [(HsDecl)]+collectSigsFromRhs (HsUnGuardedRhs e) = collectSigsFromExp e+collectSigsFromRhs (HsGuardedRhss rhss) = concatMap collectSigsFromGuardedRhs rhss++collectSigsFromGuardedRhs :: (HsGuardedRhs) -> [(HsDecl)]+collectSigsFromGuardedRhs (HsGuardedRhs _ e1 e2)+   = collectSigsFromExp e1 +++     collectSigsFromExp e2++collectSigsFromExp :: HsExp -> [HsDecl]+collectSigsFromExp e = fromSC (collectExp e)++collectExp :: HsExp -> SC ()+collectExp (HsLet decls e) = do+    addSigs (collectSigsFromDecls decls)+    collectExp e+collectExp (HsCase e alts) = do+    collectExp e+    addSigs $ concatMap collectSigsFromAlt alts+collectExp (HsDo stmts) = addSigs $ concatMap collectSigsFromStmt stmts+collectExp (HsListComp e stmts) = do+    collectExp e+    addSigs $ concatMap collectSigsFromStmt stmts+collectExp e =  traverseHsExp_ collectExp e++collectSigsFromAlt :: (HsAlt) -> [(HsDecl)]+collectSigsFromAlt (HsAlt _ _ (HsUnGuardedRhs e) decls)+   = collectSigsFromExp e +++     collectSigsFromDecls decls+collectSigsFromAlt (HsAlt _ _ (HsGuardedRhss alts) decls)+   = concatMap collectSigsFromGuardedAlt alts +++     collectSigsFromDecls decls++collectSigsFromGuardedAlt :: (HsGuardedRhs) -> [(HsDecl)]+collectSigsFromGuardedAlt (HsGuardedRhs _ e1 e2)+   = collectSigsFromExp e1 +++     collectSigsFromExp e2++collectSigsFromStmt :: (HsStmt) -> [(HsDecl)]+collectSigsFromStmt (HsGenerator _ _ e) = collectSigsFromExp e+collectSigsFromStmt (HsQualifier e) = collectSigsFromExp e+collectSigsFromStmt (HsLetStmt decls) = collectSigsFromDecls decls++--------------------------------------------------------------------------------++type SigEnv = Map.Map Name Type++listSigsToSigEnv :: KindEnv -> [HsDecl] -> SigEnv+listSigsToSigEnv kt sigs+   = Map.fromList $ concatMap (aHsTypeSigToAssumps kt) sigs++aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)]+aHsTypeSigToAssumps kt sig@(~(HsTypeSig _ names qualType)) = [ (toName Val n,typ) | n <- names] where+    Identity typ = hsQualTypeToSigma kt qualType
+ src/FrontEnd/TypeSynonyms.hs view
@@ -0,0 +1,131 @@+module FrontEnd.TypeSynonyms (+    removeSynonymsFromType,+    declsToTypeSynonyms,+    TypeSynonyms,+    restrictTypeSynonyms,+    showSynonyms,+    showSynonym+    ) where++import Control.Monad.Writer+import Data.Binary+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set++import Doc.DocLike+import FrontEnd.HsSyn+import FrontEnd.SrcLoc+import FrontEnd.Syn.Traverse+import FrontEnd.Warning+import GenUtil+import Name.Name+import Support.FreeVars+import Support.MapBinaryInstance+import Util.HasSize+import Util.UniqueMonad+import qualified Util.Graph as G++newtype TypeSynonyms = TypeSynonyms (Map.Map Name ([HsName], HsType, SrcLoc))+    deriving(Monoid,HasSize)++instance Binary TypeSynonyms where+    put (TypeSynonyms ts) = putMap ts+    get = fmap TypeSynonyms getMap++restrictTypeSynonyms :: (Name -> Bool) -> TypeSynonyms -> TypeSynonyms+restrictTypeSynonyms f (TypeSynonyms fm) = TypeSynonyms (Map.filterWithKey (\k _ -> f k) fm)++showSynonym :: (DocLike d,Monad m) => (HsType -> d) -> Name -> TypeSynonyms -> m d+showSynonym pprint n (TypeSynonyms m) =+    case Map.lookup n m of+      Just (ns, t, _) -> return $ hsep (tshow n:map tshow ns) <+> text "=" <+> pprint t+      Nothing         -> fail "key not found"++showSynonyms :: DocLike d => (HsType -> d) -> TypeSynonyms -> d+showSynonyms pprint (TypeSynonyms m) = vcat (map f (Map.toList m)) where+    f (n,(ns,t,_)) =  hsep (tshow n:map tshow ns) <+> text "=" <+> pprint t++-- | convert a set of type synonym declarations to a synonym map used for efficient synonym+-- expansion++--declsToTypeSynonyms :: [HsDecl] -> TypeSynonyms+--declsToTypeSynonyms ts = TypeSynonyms $ Map.fromList $+--    [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args' t) <- ts, let args = [ n | ~(HsTyVar n) <- args'] ]+--     ++ [ (toName TypeConstructor name,( args , HsTyAssoc, sl)) | (HsClassDecl _ _ ds) <- ts,(HsTypeDecl sl name args' _) <- ds, let args = [ n | ~(HsTyVar n) <- args'] ]++-- | convert a set of type synonym declarations to a synonym map used for efficient synonym+-- expansion, expanding out the body of synonyms along the way.++declsToTypeSynonyms :: MonadWarn m => TypeSynonyms -> [HsDecl] -> m TypeSynonyms+declsToTypeSynonyms tsin ds = f tsin gr [] where+    gr = G.scc $ G.newGraph [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args' t) <- ds, let args = [ n | ~(HsTyVar n) <- args'] ] fst (Set.toList . freeVars . (\ (_,(_,t,_)) -> t))+    f tsin (Right ns:xs) rs = do+            warn (head [ sl | (_,(_,_,sl)) <- ns]) TypeSynonymRecursive ("Recursive type synonyms:" <+> show (fsts ns))+            f tsin xs rs+    f tsin (Left (n,(as,body,sl)):xs) rs = do+        body' <- removeSynonymsFromType tsin body+        f (tsInsert n (as,body',sl) tsin) xs ((n,(as,body',sl)):rs)+    f _ [] rs = return $ TypeSynonyms (Map.fromList rs)++tsInsert x y (TypeSynonyms xs) = TypeSynonyms (Map.insert x y xs)++removeSynonymsFromType :: MonadWarn m => TypeSynonyms -> HsType -> m HsType+removeSynonymsFromType syns t = evalTypeSyms  syns t++quantifyHsType :: [HsName] -> HsQualType -> HsType+quantifyHsType inscope t+  | null vs, null (hsQualTypeContext t) = hsQualTypeType t+  | otherwise  = HsTyForall vs t   where+    vs = map g $ snub (execWriter (fv (hsQualTypeType t))) \\ inscope+    g n = hsTyVarBind { hsTyVarBindName = n }+    fv (HsTyVar v) = tell [v]+    fv (HsTyForall vs qt) = tell $ snub (execWriter (fv $ hsQualTypeType qt)) \\ map hsTyVarBindName vs+    fv (HsTyExists vs qt) = tell $ snub (execWriter (fv $ hsQualTypeType qt)) \\ map hsTyVarBindName vs+    fv x = traverseHsType (\x -> fv x >> return x) x >> return ()++evalTypeSyms :: MonadWarn m => TypeSynonyms -> HsType -> m HsType+evalTypeSyms (TypeSynonyms tmap) t = execUniqT 1 (eval [] t) where+    eval stack x@(HsTyCon n) | Just (args, t, sl) <- Map.lookup (toName TypeConstructor n) tmap = do+        let excess = length stack - length args+        if (excess < 0) then do+            lift $ warn sl TypeSynonymPartialAp ("Partially applied typesym:" <+> show n <+> "need" <+> show (- excess) <+> "more arguments.")+            unwind x stack+          else case t of+            HsTyAssoc -> unwind x stack+            _ -> do+                st <- subst (Map.fromList [(a,s) | a <- args | s <- stack]) t+                eval (drop (length args) stack) st+    eval stack (HsTyApp t1 t2) = eval (t2:stack) t1+    eval stack x = do+        t <- traverseHsType (eval []) x+        unwind t stack+    unwind t [] = return t+    unwind t (t1:rest) = do+        t1' <- eval [] t1+        unwind (HsTyApp t t1') rest+    subst sm (HsTyForall vs t) = do+        ns <- mapM (const newUniq) vs+        let nvs = [ (hsTyVarBindName v,v { hsTyVarBindName = hsNameIdent_u ((show n ++ "00") ++) (hsTyVarBindName v)})| (n,v) <- zip ns vs ]+            nsm = Map.fromList [ (v,HsTyVar $ hsTyVarBindName t)| (v,t) <- nvs] `Map.union` sm+        t' <- substqt nsm t+        return $ HsTyForall (snds nvs)  t'+    subst sm (HsTyExists vs t) = do+        ns <- mapM (const newUniq) vs+        let nvs = [ (hsTyVarBindName v,v { hsTyVarBindName = hsNameIdent_u (hsIdentString_u ((show n ++ "00") ++)) (hsTyVarBindName v)})| (n,v) <- zip ns vs ]+            nsm = Map.fromList [ (v,HsTyVar $ hsTyVarBindName t)| (v,t) <- nvs] `Map.union` sm+        t' <- substqt nsm t+        return $ HsTyExists (snds nvs)  t'+    subst (sm::(Map.Map HsName HsType))  (HsTyVar n) | Just v <- Map.lookup n sm = return v+    subst sm t = traverseHsType (subst sm) t+    substqt sm qt@HsQualType { hsQualTypeContext = ps, hsQualTypeType = t } = do+        t' <- subst sm t+        let f (HsAsst c xs) = return (HsAsst c (map g xs))+            f (HsAsstEq a b) = do+                a' <- subst sm a+                b' <- subst sm b+                return (HsAsstEq a' b')+            g n =  case Map.lookup n sm of Just (HsTyVar n') -> n' ; _ -> n+        ps' <- mapM f ps -- = [ case Map.lookup n sm of Just (HsTyVar n') -> (c,n') ; _ -> (c,n) | (c,n) <- ps ]++        return qt { hsQualTypeType = t', hsQualTypeContext = ps' }
+ src/FrontEnd/TypeSyns.hs view
@@ -0,0 +1,510 @@+module FrontEnd.TypeSyns( expandTypeSyns, expandTypeSynsStmt ) where++import Control.Monad.State+import Control.Monad.Writer+import Data.List+import qualified Data.Traversable as T++import FrontEnd.HsSyn+import FrontEnd.SrcLoc hiding(srcLoc)+import FrontEnd.Syn.Traverse+import FrontEnd.TypeSynonyms+import FrontEnd.Warning+import Name.Name++type SubTable = ()++-- the monadic state++data ScopeState = ScopeState {+    currentModule  :: Module,+    errors         :: [Warning],+    synonyms       :: TypeSynonyms,+    srcLoc         :: !SrcLoc+    }++-- The monadic type+type ScopeSM = State ScopeState++instance MonadWarn ScopeSM where+    addWarning w = modify (\s -> s { errors = w: errors s})++instance MonadSrcLoc ScopeSM where+    getSrcLoc = gets srcLoc+instance MonadSetSrcLoc ScopeSM where+    withSrcLoc sl a = modify (\s -> s { srcLoc = sl `mappend` srcLoc s}) >> a++expandTypeSyns :: MonadWarn m => TypeSynonyms -> HsModule -> m HsModule+expandTypeSyns syns m = ans where+    startState = ScopeState {+        errors         = [],+        synonyms       =  syns,+        srcLoc         = bogusASrcLoc,+        currentModule  = hsModuleName m+        }++    (rm, fs) = runState (renameDecls m) startState+    ans = do+        mapM_ addWarning (errors fs)+        return rm++expandTypeSynsStmt :: MonadWarn m => TypeSynonyms -> Module -> HsStmt -> m HsStmt+expandTypeSynsStmt syns mod m = ans where+    startState = ScopeState {+        errors         = [],+        synonyms       =  syns,+        srcLoc         = bogusASrcLoc,+        currentModule  = mod+        }++    (rm, fs) = runState (renameHsStmt m ()) startState+    ans = do+        mapM_ addWarning (errors fs)+        return rm++-- This is Bryn's modification to make the code a bit easier to understand for+-- functions like renameHsNames, renameHsFileUpdates+mapRename :: (a -> SubTable -> ScopeSM a) -> [a] -> SubTable -> ScopeSM [a]+mapRename renameIndividual individuals subTable+    = mapM (`renameIndividual` subTable) individuals++renameDecls :: HsModule -> ScopeSM HsModule+renameDecls tidy = do+        decls' <- renameHsDecls (hsModuleDecls tidy) undefined+        return tidy { hsModuleDecls = decls' }++renameHsDecls :: [HsDecl] -> SubTable -> ScopeSM ([HsDecl])+renameHsDecls decls subtable = do+    ans <- mapRename renameHsDecl (expandTypeSigs decls) subtable+    return ans++expandTypeSigs :: [HsDecl] -> [HsDecl]+expandTypeSigs ds =  (concatMap f ds) where+    f (HsTypeSig sl ns qt) =  [ HsTypeSig sl [n] qt | n <- ns]+    f d = return d++renameHsDecl :: HsDecl -> SubTable -> ScopeSM (HsDecl)+renameHsDecl (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) subTable = withSrcLoc srcLoc $ do+    hsPat'    <- renameHsPat hsPat subTable+    hsDecls'  <- renameHsDecls hsDecls subTable+    hsRhs'    <- renameHsRhs hsRhs subTable+    let patbind' = (HsPatBind srcLoc hsPat' hsRhs' {-where-} hsDecls')+    return patbind'++renameHsDecl (HsForeignDecl a b n t) subTable = withSrcLoc a $ do+    n <- renameHsName n subTable+    t <- renameHsQualType t subTable+    return  (HsForeignDecl a b n t)++renameHsDecl (HsForeignExport a b n t) subTable = withSrcLoc a $ do+    n <- renameHsName n subTable+    t <- renameHsQualType t subTable+    return  (HsForeignExport a b n t)++renameHsDecl (HsFunBind hsMatches) subTable = do+    hsMatches' <- renameHsMatches hsMatches subTable+    return (HsFunBind hsMatches')++renameHsDecl (HsTypeSig srcLoc hsNames hsQualType) subTable = withSrcLoc srcLoc $ do+    hsNames' <- renameHsNames hsNames subTable+    hsQualType' <- renameHsQualType hsQualType subTable+    return (HsTypeSig srcLoc hsNames' hsQualType')++renameHsDecl dl@HsDataDecl { hsDeclContext = hsContext, hsDeclCons = hsConDecls  } subTable = do+    hsContext' <- renameHsContext hsContext subTable+    hsConDecls' <- renameHsConDecls hsConDecls subTable+    return dl { hsDeclContext = hsContext', hsDeclCons = hsConDecls' }+renameHsDecl (HsTypeDecl srcLoc name hsNames t) subTable = withSrcLoc srcLoc $ do+    hsName' <- renameTypeHsName name subTable+    t' <- renameHsType' False t undefined+    return (HsTypeDecl srcLoc  hsName' hsNames t')+renameHsDecl decl@HsActionDecl { hsDeclSrcLoc = srcLoc, hsDeclExp = e }  subTable = withSrcLoc srcLoc $ do+    e <- renameHsExp e subTable+    return decl { hsDeclExp = e }+renameHsDecl (HsClassDecl srcLoc hsQualType hsDecls) subTable = withSrcLoc srcLoc $ do+    hsQualType' <- renameHsClassHead hsQualType+    hsDecls' <- renameHsDecls hsDecls subTable+    return (HsClassDecl srcLoc hsQualType' hsDecls')+renameHsDecl (HsInstDecl srcLoc hsQualType hsDecls) subTable = withSrcLoc srcLoc $ do+    hsQualType' <- renameHsClassHead hsQualType+    hsDecls' <- renameHsDecls hsDecls subTable+    return (HsInstDecl srcLoc hsQualType' hsDecls')+renameHsDecl (HsInfixDecl srcLoc assoc int hsNames) subTable = withSrcLoc srcLoc $ do+    hsNames' <- renameHsNames hsNames subTable+    return $ HsInfixDecl srcLoc assoc int hsNames'+renameHsDecl (HsPragmaRules rs) subTable = do+    rs' <- mapM (`renameHsRule` subTable) rs+    return $ HsPragmaRules rs'+renameHsDecl prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } subTable = withSrcLoc srcLoc $ do+    t <- renameHsType t subTable+    return prules {  hsDeclType = t }+renameHsDecl otherHsDecl _ = return otherHsDecl++renameHsRule prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } subTable = withSrcLoc srcLoc $ do+    fvs' <- sequence [ T.mapM (`renameHsType` subTable) t  >>= return . (,) n | (n,t) <- fvs]+    e1' <- renameHsExp e1 subTable+    e2' <- renameHsExp e2 subTable+    return prules {  hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }++renameHsQualType :: HsQualType -> SubTable -> ScopeSM (HsQualType)+renameHsQualType (HsQualType hsContext hsType) subTable = do+      hsContext' <- renameHsContext hsContext subTable+      hsType' <- renameHsType hsType subTable+      return (HsQualType hsContext' hsType')+renameHsClassHead :: HsClassHead -> ScopeSM (HsClassHead)+renameHsClassHead HsClassHead { .. }  = do+      hsClassHeadContext <- renameHsContext hsClassHeadContext ()+      hsClassHeadArgs <- mapM (flip renameHsType ()) hsClassHeadArgs+      return HsClassHead { .. }++renameHsContext :: HsContext -> SubTable -> ScopeSM (HsContext)+renameHsContext = mapRename renameHsAsst++renameHsAsst :: HsAsst -> SubTable -> ScopeSM (HsAsst)+renameHsAsst (HsAsst hsName1  hsName2s) subTable = do+      hsName1' <- renameTypeHsName hsName1 subTable  -- for class names+      hsName2s' <- mapRename renameTypeHsName hsName2s subTable+      return (HsAsst hsName1' hsName2s')+renameHsAsst (HsAsstEq t1 t2) subTable = do+      t1' <- renameHsType t1 subTable  -- for class names+      t2' <- renameHsType t2 subTable  -- for class names+      return (HsAsstEq t1' t2')++renameHsConDecls :: [HsConDecl] -> SubTable -> ScopeSM ([HsConDecl])+renameHsConDecls = mapRename renameHsConDecl++renameHsConDecl :: HsConDecl -> SubTable -> ScopeSM (HsConDecl)+renameHsConDecl cd@(HsConDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclConArg = hsBangTypes }) subTable = withSrcLoc srcLoc $ do+    hsName' <- renameHsName hsName subTable+    hsBangTypes' <- renameHsBangTypes hsBangTypes subTable+    return cd { hsConDeclName = hsName', hsConDeclConArg = hsBangTypes' }+renameHsConDecl cd@HsRecDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclRecArg = stuff} subTable = withSrcLoc srcLoc $ do+    hsName' <- renameHsName hsName subTable+    stuff' <- sequence [ do ns' <- mapRename renameHsName ns subTable; t' <- renameHsBangType t subTable; return (ns',t')  |  (ns,t) <- stuff]+    return cd { hsConDeclName = hsName', hsConDeclRecArg = stuff' }++renameHsBangTypes :: [HsBangType] -> SubTable -> ScopeSM ([HsBangType])+renameHsBangTypes = mapRename renameHsBangType++renameHsBangType :: HsBangType -> SubTable -> ScopeSM (HsBangType)+renameHsBangType (HsBangedTy hsType) subTable = do+    hsType' <- renameHsType hsType subTable+    return (HsBangedTy hsType')+renameHsBangType (HsUnBangedTy hsType) subTable = do+    hsType' <- renameHsType hsType subTable+    return (HsUnBangedTy hsType')++renameHsType = renameHsType' True++renameHsType' dovar t st = pp (rt t) where+    rt :: HsType -> ScopeSM HsType+    rt (HsTyFun hsType1 hsType2) = do+        hsType1' <- rt hsType1+        hsType2' <- rt hsType2+        return (HsTyFun hsType1' hsType2')+    rt (HsTyTuple hsTypes) = do+        hsTypes' <- mapM rt hsTypes+        return (HsTyTuple hsTypes')+    rt (HsTyUnboxedTuple hsTypes) = do+        hsTypes' <- mapM rt hsTypes+        return (HsTyUnboxedTuple hsTypes')+    rt (HsTyApp hsType1 hsType2) = do+        hsType1' <- rt hsType1+        hsType2' <- rt hsType2+        return (HsTyApp hsType1' hsType2')+    rt (HsTyVar hsName) | dovar = do+        hsName' <- renameTypeHsName hsName ()+        return (HsTyVar hsName')+    rt (HsTyCon hsName) = do+        hsName' <- renameTypeHsName hsName  ()+        return (HsTyCon hsName')+    rt (HsTyForall ts v) = do+        v <- renameHsQualType v  ()+        return $ HsTyForall ts v+    rt (HsTyExists ts v) = do+        v <- renameHsQualType v  ()+        return $ HsTyExists ts v+ --   rt (HsTyAssoc) = return HsTyAssoc+--    rt (HsTyEq a b) = return HsTyEq `ap` (flip rt a) `ap` (flip rt b)+ --   rt HsTyExpKind {} _subTable = error "cannot rename HsTyExpKind TypeSyns"+    rt ty = traverseHsType rt ty+    pp t | not dovar = t+    pp t = do+        t' <- t+        syns <- gets synonyms+        removeSynonymsFromType syns t'++renameHsMatches :: [HsMatch] -> SubTable -> ScopeSM [HsMatch]+renameHsMatches = mapRename renameHsMatch++-- note that for renameHsMatch, the 'wheres' dominate the 'pats'++renameHsMatch :: HsMatch -> SubTable -> ScopeSM HsMatch+renameHsMatch (HsMatch srcLoc hsName hsPats hsRhs {-where-} hsDecls) subTable = withSrcLoc srcLoc $ do+    hsName' <- renameHsName hsName subTable+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc+    hsPats' <- renameHsPats hsPats subTable'+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls+    hsDecls' <- renameHsDecls hsDecls subTable''+    hsRhs' <- renameHsRhs hsRhs subTable''+    return (HsMatch srcLoc hsName' hsPats' hsRhs' {-where-} hsDecls')++renameHsPats :: [HsPat] -> SubTable -> ScopeSM ([HsPat])+renameHsPats = mapRename renameHsPat++renameHsPat :: HsPat -> SubTable -> ScopeSM (HsPat)+renameHsPat (HsPTypeSig srcLoc hsPat qt) subTable = withSrcLoc srcLoc $ do+    hsQualType' <- renameHsQualType qt subTable+    hsPat' <- renameHsPat hsPat subTable+    return (HsPTypeSig srcLoc hsPat' hsQualType')+renameHsPat p subTable = traverseHsPat (flip renameHsPat subTable) p++renameHsRhs :: HsRhs -> SubTable -> ScopeSM HsRhs+renameHsRhs (HsUnGuardedRhs hsExp) subTable = do+      hsExp' <- renameHsExp hsExp subTable+      return (HsUnGuardedRhs hsExp')+renameHsRhs (HsGuardedRhss hsGuardedRhss) subTable = do+      hsGuardedRhss' <- renameHsGuardedRhsList hsGuardedRhss subTable+      return (HsGuardedRhss hsGuardedRhss')++renameHsExp :: HsExp -> SubTable -> ScopeSM HsExp+renameHsExp (HsLambda srcLoc hsPats hsExp) subTable = withSrcLoc srcLoc $ do+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc+    hsPats' <- renameHsPats hsPats subTable'+    hsExp' <- renameHsExp hsExp subTable'+    return (HsLambda srcLoc hsPats' hsExp')+renameHsExp (HsLet hsDecls hsExp) subTable = do+    subTable' <- updateSubTableWithHsDecls subTable hsDecls+    hsDecls' <- renameHsDecls hsDecls subTable'+    hsExp' <- renameHsExp hsExp subTable'+    return (HsLet hsDecls' hsExp')+renameHsExp (HsCase hsExp hsAlts) subTable = do+    hsExp' <- renameHsExp hsExp subTable+    hsAlts' <- renameHsAlts hsAlts subTable+    return (HsCase hsExp' hsAlts')+renameHsExp (HsRecConstr hsName hsFieldUpdates) subTable = do+    hsName' <- renameHsName hsName subTable  -- do I need to change this name?+    hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates subTable+    return (HsRecConstr hsName' hsFieldUpdates')+renameHsExp (HsRecUpdate hsExp hsFieldUpdates) subTable = do+    hsExp' <- renameHsExp hsExp subTable+    hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates subTable+    return (HsRecUpdate hsExp' hsFieldUpdates')+renameHsExp (HsListComp hsExp hsStmts) subTable = do+    (hsStmts',subTable') <- renameHsStmts hsStmts subTable+    hsExp' <- renameHsExp hsExp subTable'+    return (HsListComp hsExp' hsStmts')+renameHsExp (HsExpTypeSig srcLoc hsExp hsQualType) subTable = do+    hsExp' <- renameHsExp hsExp subTable+    subTable' <- updateSubTableWithHsQualType subTable hsQualType+    hsQualType' <- renameHsQualType hsQualType subTable'+    return (HsExpTypeSig srcLoc hsExp' hsQualType')+renameHsExp e subTable = traverseHsExp (flip renameHsExp subTable) e++renameHsAlts :: [HsAlt] -> SubTable -> ScopeSM [HsAlt]+renameHsAlts = mapRename renameHsAlt++-- note for renameHsAlt, the 'wheres' dominate the 'pats'++renameHsAlt :: HsAlt -> SubTable -> ScopeSM (HsAlt)+renameHsAlt (HsAlt srcLoc hsPat hsGuardedAlts {-where-} hsDecls) subTable = withSrcLoc srcLoc $ do+    subTable' <- updateSubTableWithHsPats subTable [hsPat] srcLoc+    hsPat' <- renameHsPat hsPat subTable'+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls+    hsDecls' <- renameHsDecls hsDecls subTable''+    hsGuardedAlts' <- renameHsRhs hsGuardedAlts subTable''+    return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')++renameHsGuardedRhsList :: [HsGuardedRhs] -> SubTable -> ScopeSM [HsGuardedRhs]+renameHsGuardedRhsList = mapRename renameHsGuardedRhs++renameHsGuardedRhs :: HsGuardedRhs -> SubTable -> ScopeSM HsGuardedRhs+renameHsGuardedRhs (HsGuardedRhs srcLoc hsExp1 hsExp2) subTable = withSrcLoc srcLoc $ do+    hsExp1' <- renameHsExp hsExp1 subTable+    hsExp2' <- renameHsExp hsExp2 subTable+    return (HsGuardedRhs srcLoc hsExp1' hsExp2')++-- renameHsStmts is trickier than you would expect because+-- the statements are only in scope after they have been declared+-- and thus the subTable must be more carefully threaded through++-- the updated subTable is returned at the end because it is needed by+-- the first section of a list comprehension.++renameHsStmts :: [HsStmt] -> SubTable -> ScopeSM (([HsStmt],SubTable))+renameHsStmts (hsStmt:hsStmts) subTable = do+      subTable' <- updateSubTableWithHsStmt subTable hsStmt+      hsStmt' <- renameHsStmt hsStmt subTable'+      (hsStmts',subTable'') <- renameHsStmts hsStmts subTable'+      return ((hsStmt':hsStmts'),subTable'')+renameHsStmts [] subTable = do+      return ([],subTable)++renameHsStmt :: HsStmt -> SubTable -> ScopeSM (HsStmt)+renameHsStmt (HsGenerator srcLoc hsPat hsExp) subTable = do+      hsExp' <- renameHsExp hsExp subTable+      hsPat' <- renameHsPat hsPat subTable+      return (HsGenerator srcLoc hsPat' hsExp')+renameHsStmt (HsQualifier hsExp) subTable = do+      hsExp' <- renameHsExp hsExp subTable+      return (HsQualifier hsExp')+renameHsStmt (HsLetStmt hsDecls) subTable = do+      hsDecls' <- renameHsDecls hsDecls subTable+      return (HsLetStmt hsDecls')++renameHsFieldUpdates :: [HsFieldUpdate] -> SubTable -> ScopeSM ([HsFieldUpdate])+renameHsFieldUpdates = mapRename renameHsFieldUpdate++renameHsFieldUpdate :: HsFieldUpdate -> SubTable -> ScopeSM (HsFieldUpdate)+-- XXX I'm not 100% sure that this works+{-+renameHsFieldUpdate (HsFieldBind hsName) subTable+  = do+      hsName' <- renameHsName hsName subTable  -- do i need to rename this name?+      return (HsFieldBind hsName')+-}+renameHsFieldUpdate (HsFieldUpdate hsName hsExp) subTable = do+    hsName' <- renameHsName hsName undefined+    hsExp' <- renameHsExp hsExp subTable+    return (HsFieldUpdate hsName' hsExp')++renameHsNames :: [HsName] -> SubTable -> ScopeSM ([HsName])+renameHsNames ns _ = return ns++-- This looks up a replacement name in the subtable.+-- Regardless of whether the name is found, if it's not qualified+-- it will be qualified with the current module's prefix.+renameHsName :: HsName -> SubTable -> ScopeSM (HsName)+renameHsName hsName _ = return hsName++renameTypeHsName hsName subTable  =  return hsName++---------------------------------------+-- utility functions++-- clobberHsName(s) is called by the updateSubTableWith* functions to+-- deal with newly declared identifiers++-- clobberHsName(s) adds new mappings to the SubTable.+-- If a name already appeared, it's mapping is altered to the new one.++-- clobberHsNamesAndUpdateIdentTable also adds a mapping from this+-- renamed name to its source location and binding type++clobberHsNamesAndUpdateIdentTable :: [(HsName,SrcLoc)] -> SubTable ->  ScopeSM (SubTable)+clobberHsNamesAndUpdateIdentTable ((hsName,srcLoc):hsNamesAndASrcLocs) subTable  = do+      subTable'  <- clobberHsName hsName subTable+      subTable'' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable'+      return (subTable'')+clobberHsNamesAndUpdateIdentTable [] subTable  = return (subTable)++{-+clobberHsNameAndUpdateIdentTable :: HsName -> SrcLoc -> SubTable -> Binding -> ScopeSM (SubTable)+clobberHsNameAndUpdateIdentTable hsName srcLoc subTable binding+  = do+      unique <- getUnique+      currModule <- getCurrentModule+      let+        hsName'     = renameAndQualify hsName unique currModule+        subTable'   = addToFM (addToFM subTable hsName hsName') hsName' hsName'+      addToIdentTable hsName' (srcLoc, binding)+      incUnique+      return (subTable')+-}++-- takes a list of names and a subtable. adds the associations+-- [name -> renamedName] to the table and returns it.+clobberHsNames :: [HsName] -> SubTable -> ScopeSM (SubTable)+clobberHsNames (hsName:hsNames) subTable+  = do+      subTable'  <- clobberHsName  hsName  subTable+      subTable'' <- clobberHsNames hsNames subTable'+      return (subTable'')+clobberHsNames [] subTable+  = return subTable++clobberHsName :: HsName -> SubTable -> ScopeSM (SubTable)+clobberHsName hsName subTable = return subTable++--------------------------------------------------------+----This section of code updates the current SubTable to reflect the present scope++updateSubTableWithHsDecls :: SubTable -> [HsDecl] ->  ScopeSM (SubTable)+updateSubTableWithHsDecls subTable []  = return subTable+updateSubTableWithHsDecls subTable (hsDecl:hsDecls) = do+    let hsNamesAndASrcLocs = getHsNamesAndASrcLocsFromHsDecl hsDecl+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls+    return (subTable'')++updateSubTableWithHsPats :: SubTable -> [HsPat] -> SrcLoc -> ScopeSM (SubTable)+updateSubTableWithHsPats subTable (hsPat:hsPats) srcLoc  = do+    let hsNamesAndASrcLocs = zip (getNamesFromHsPat hsPat) (repeat srcLoc)+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable+    subTable'' <- updateSubTableWithHsPats subTable' hsPats srcLoc+    return subTable''+updateSubTableWithHsPats subTable [] _srcLoc = do return (subTable)++-- Only one HsStmt should be added at a time because each new identifier is only valid+-- below the point at which it is defined++updateSubTableWithHsStmt :: SubTable -> HsStmt -> ScopeSM (SubTable)+updateSubTableWithHsStmt subTable hsStmt = do+    let hsNamesAndASrcLocs = getHsNamesAndASrcLocsFromHsStmt hsStmt+    subTable' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable+    return (subTable')++----------------------------------------------------------+-- the following updateSubTableWith* functions do not need to alter the identTable aswell+--++-- takes an HsQualType (a type signature) and adds the names of its variables+-- to the current subTable++updateSubTableWithHsQualType :: SubTable -> HsQualType -> ScopeSM (SubTable)+updateSubTableWithHsQualType subTable hsQualType = do+      let hsNames = nub $ getHsNamesFromHsQualType hsQualType+      subTable' <- clobberHsNames hsNames subTable+      return (subTable')++getHsNamesAndASrcLocsFromHsDecl :: HsDecl -> [(HsName, SrcLoc)]+getHsNamesAndASrcLocsFromHsDecl (HsPatBind srcLoc (HsPVar hsName) _ _) = [(hsName, srcLoc)]+-- This will cause errors on code with PatBinds of the form (x,y) = blah...+-- and should be changed for a more general renamer (but is fine for thih)+getHsNamesAndASrcLocsFromHsDecl (HsPatBind sloc _ _ _)+  = error $ "non simple pattern binding found (sloc): " ++ show sloc+-- getHsNamesAndASrcLocsFromHsDecl (HsFunBind _ hsMatches)+getHsNamesAndASrcLocsFromHsDecl (HsFunBind hsMatches) = getHsNamesAndASrcLocsFromHsMatches hsMatches+getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ n _) = [(n,a)]+getHsNamesAndASrcLocsFromHsDecl _otherHsDecl = []++getHsNamesAndASrcLocsFromHsMatches :: [HsMatch] -> [(HsName, SrcLoc)]+getHsNamesAndASrcLocsFromHsMatches [] = []+getHsNamesAndASrcLocsFromHsMatches (hsMatch:_hsMatches) = getHsNamesAndASrcLocsFromHsMatch hsMatch++getHsNamesAndASrcLocsFromHsMatch :: HsMatch -> [(HsName, SrcLoc)]+getHsNamesAndASrcLocsFromHsMatch (HsMatch srcLoc hsName _ _ _)+  = [(hsName, srcLoc)]++getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)]+getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)+getHsNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []+getHsNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getHsNamesAndASrcLocsFromHsDecl hsDecls++-- the getNew... functions are used only inside class declarations to avoid _re_ renaming things+-- that should be left as is.++getHsNamesFromHsQualType :: HsQualType -> [HsName]+getHsNamesFromHsQualType (HsQualType _hsContext hsType) = getHsNamesFromHsType hsType++getHsNamesFromHsType :: HsType -> [HsName]+getHsNamesFromHsType (HsTyFun hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)+getHsNamesFromHsType (HsTyTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes+getHsNamesFromHsType (HsTyUnboxedTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes+getHsNamesFromHsType (HsTyApp hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)+getHsNamesFromHsType (HsTyVar hsName) = [hsName]+getHsNamesFromHsType (HsTyForall vs qt) = getHsNamesFromHsQualType qt Data.List.\\ map hsTyVarBindName vs+getHsNamesFromHsType (HsTyExists vs qt) = getHsNamesFromHsQualType qt Data.List.\\ map hsTyVarBindName vs+getHsNamesFromHsType (HsTyCon _hsName) = [] -- don't rename the Constructors+getHsNamesFromHsType ty = execWriter $ traverseHsType_ f ty where+    f t = tell $ getHsNamesFromHsType t
+ src/FrontEnd/Unlit.hs view
@@ -0,0 +1,80 @@+module FrontEnd.Unlit(unlit) where++-- Part of the following code is from+-- "Report on the Programming Language Haskell",+--   version 1.2, appendix C.+++import Data.Char++data Classified = Program String | Blank | Comment+                | Include Int String | Pre String++classify :: [String] -> [Classified]+classify []                = []+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs+   where allProg [] = []  -- Should give an error message,+                          -- but I have no good position information.+         allProg (('\\':x):xs) |  x == "end{code}" = Blank : classify xs+	 allProg (x:xs) = Program x:allProg xs+classify (('>':x):xs)      = Program (' ':x) : classify xs+classify (('#':'l':'i':'n':'e':' ':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line+                                   -> Include (read line) file+                                _  -> Pre x+                             ) : classify xs+classify (('#':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line+                                   -> Include (read line) file+                                _  -> Pre x+                             ) : classify xs+classify (x:xs) | all isSpace x = Blank:classify xs+classify (x:xs)                 = Comment:classify xs++unclassify :: Classified -> String+unclassify (Program s) = s+unclassify (Pre s)     = '#':s+unclassify (Include i f) = '#':' ':show i ++ ' ':f+unclassify Blank       = ""+unclassify Comment     = ""+++-- | Remove literate comments leaving normal haskell source.++unlit ::+    String      -- ^ Filename for error messages+    -> String   -- ^ literate source+    -> String   -- ^ deliterated source+unlit file lhs = (unlines+                 . map unclassify+                 . adjecent file (0::Int) Blank+                 . classify) (inlines lhs)++adjecent :: String -> Int -> Classified -> [Classified] -> [Classified]+adjecent file 0 _             (x              :xs) = x : adjecent file 1 x xs -- force evaluation of line number+adjecent file n y@(Program _) (x@Comment      :xs) = error (message file n "program" "comment")+adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@(Program _) (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Comment     (x@(Program _)  :xs) = error (message file n "comment" "program")+adjecent file n y@Comment     (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Comment     (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Blank       (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Blank       (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n _             (x@next         :xs) = x: adjecent file (n+1) x xs+adjecent file n _             []                    = []++message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message []     n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message file   n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"+++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+inlines s = lines' s id+  where+  lines' []             acc = [acc []]+  lines' ('\^M':'\n':s) acc = acc [] : lines' s id	-- DOS+  lines' ('\^M':s)      acc = acc [] : lines' s id	-- MacOS+  lines' ('\n':s)       acc = acc [] : lines' s id	-- Unix+  lines' (c:s)          acc = lines' s (acc . (c:))+
+ src/FrontEnd/Utils.hs view
@@ -0,0 +1,36 @@+module FrontEnd.Utils where++import Data.Char+import Control.Monad.Identity+import qualified Data.Map as Map++import Doc.DocLike+import Doc.PPrint+import FrontEnd.HsSyn+import Name.Name++maybeGetDeclName :: Monad m => HsDecl -> m Name+maybeGetDeclName (HsPatBind sloc (HsPVar name) rhs wheres) = return (toName Val name)+maybeGetDeclName (HsActionDecl sloc (HsPVar name) _) = return (toName Val name)+maybeGetDeclName (HsFunBind ((HsMatch _ name _ _ _):_)) = return (toName Val name)+maybeGetDeclName HsDataDecl { hsDeclDeclType = DeclTypeKind, hsDeclName } = return (toName SortName hsDeclName)+maybeGetDeclName HsDataDecl { hsDeclName = name } = return (toName TypeConstructor name)+maybeGetDeclName HsClassDecl { hsDeclClassHead = h } = return $ toName ClassName $ hsClassHead h+maybeGetDeclName x@HsForeignDecl {} = return $ toName Val $ hsDeclName x+maybeGetDeclName (HsForeignExport _ e _ _)   = return $ ffiExportName e+--maybeGetDeclName (HsTypeSig _ [n] _ ) = return n+maybeGetDeclName d = fail  $ "getDeclName: could not find name for a decl: " ++ show d++getDeclName :: HsDecl -> Name+getDeclName d =  runIdentity $ maybeGetDeclName d++-- | Convert name to what it was before renaming.++hsNameToOrig :: HsName -> HsName+hsNameToOrig n = hsNameIdent_u (hsIdentString_u dn) n where+    dn xs = case dropWhile isDigit xs of+        ('_':xs) -> xs+        _ -> error $ "hsNameToOrig: " ++ show n++pprintEnvMap :: (PPrint d k, PPrint d a) => Map.Map k a -> d+pprintEnvMap m = vcat [ pprint x <+> text "::" <+> pprint y | (x,y) <- Map.toList m ]
+ src/FrontEnd/Warning.hs view
@@ -0,0 +1,162 @@+module FrontEnd.Warning(+    Warning(..),+    MonadWarn(..),+    WarnType(..),+    processErrors,+    warn,+    err,+    addWarn,+    -- IO monad+    processIOErrors,+    printIOErrors+    ) where++import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer+import Data.IORef+import System.IO.Unsafe++import FrontEnd.SrcLoc+import Name.Name+import Options+import PackedString+import StringTable.Atom+import Util.Gen++data Warning = Warning {+    warnSrcLoc  :: !SrcLoc,+    warnType    :: WarnType,+    warnMessage :: String+    } deriving(Eq,Ord)++class Monad m => MonadWarn m where+    addWarning :: Warning -> m ()+    addWarning w = fail $ show w++addWarn :: (MonadWarn m, MonadSrcLoc m) => WarnType -> String -> m ()+addWarn t m = do+    sl <- getSrcLoc+    warn sl t m++warn :: MonadWarn m => SrcLoc -> WarnType -> String -> m ()+warn s t m = addWarning Warning+    { warnSrcLoc = s, warnType = t, warnMessage = m }++err :: MonadWarn m => WarnType -> String -> m ()+err t m = warn bogusASrcLoc t m++pad n s = case length s of+    x | x >= n -> s+    x -> s ++ replicate (n - x) ' '++processIOErrors :: IO ()+processIOErrors = do+    ws <- readIORef ioWarnings+    processErrors' True ws+    writeIORef ioWarnings []++-- | just show IO errors and return whether it would have died+printIOErrors :: IO Bool+printIOErrors = do+    ws <- readIORef ioWarnings+    b <- processErrors' False ws+    writeIORef ioWarnings []+    return b++processErrors :: [Warning] -> IO ()+processErrors ws = processErrors' True ws >> return ()++processErrors' :: Bool -> [Warning] -> IO Bool+processErrors' _ [] = return False+processErrors' doDie ws = putErrLn "" >> mapM_ s (snub ws) >> when (die && doDie) exitFailure >> return die where+--    ws' = filter ((`notElem` ignore) . warnType ) $ snub ws+    s Warning { warnSrcLoc = sl, warnType = t, warnMessage = m }+        | sl == bogusASrcLoc = putErrLn $ msg t m+    s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = -1 },+                warnType = t ,warnMessage = m } = putErrLn (unpackPS fn ++ ": "  ++ msg t m)+    s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l },+                warnType = t ,warnMessage = m } = putErrLn (unpackPS fn ++ ":" ++ pad 3 (show l) ++  " - "  ++ msg t m)+    die = (any warnIsFatal (map warnType ws)) && not (optKeepGoing options)++data WarnType+    = AmbiguousExport Module [Name]+    | AmbiguousName Name [Name]+    | DuplicateInstances+    | InvalidDecl+    | MissingDep String+    | MissingModule Module+    | MultiplyDefined Name [SrcLoc]+    | InvalidFFIType+    | OccursCheck+    | PrimitiveBadType+    | PrimitiveUnknown Atom+    | TypeSynonymPartialAp+    | TypeSynonymRecursive+    | UndefinedName Name+    | UnificationError+    | UnknownDeriving [Class]+    | UnknownOption+    | UnknownPragma PackedString+    | UnsupportedFeature+    deriving(Eq,Ord)++warnIsFatal w = f w where+    f AmbiguousExport {} = True+    f AmbiguousName {} = True+    f InvalidDecl {} = True+    f InvalidFFIType {} = True+    f DuplicateInstances {} = True+    f MissingDep {} = True+    f MissingModule {} = True+    f MultiplyDefined {} = True+    f OccursCheck {} = True+    f TypeSynonymPartialAp {} = True+    f TypeSynonymRecursive {} = True+    f UndefinedName {} = True+    f UnificationError {} = True+    f UnknownDeriving {} = True+    f UnsupportedFeature {} = True+    f _ = False++instance Show Warning where+    show  Warning { warnSrcLoc = sl, warnType = t, warnMessage = m }+        | sl == bogusASrcLoc =  msg t m+    show  Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l },+                                          warnType = t ,warnMessage = m } =+         (unpackPS fn ++ ":" ++ pad 3 (show l) ++  " - "  ++ msg t m)+msg t m = (if warnIsFatal t then "Error: " else "Warning: ") ++ m++_warnings = [+    ("deprecations", "warn about uses of functions & types that are deprecated"),+    ("duplicate-exports", "warn when an entity is exported multiple times"),+    ("hi-shadowing", "warn when a .hi file in the current directory shadows a library"),+    ("incomplete-patterns", "warn when a pattern match could fail"),+    ("misc", "enable miscellaneous warnings"),+    ("missing-fields", "warn when fields of a record are uninitialised"),+    ("missing-methods", "warn when class methods are undefined"),+    ("missing-signatures", "warn about top-level functions without signatures"),+    ("name-shadowing", "warn when names are shadowed"),+    ("overlapping-patterns", "warn about overlapping patterns"),+    ("simple-patterns", "warn about lambda-patterns that can fail"),+    ("type-defaults", "warn when defaulting happens"),+    ("unused-binds", "warn about bindings that are unused"),+    ("unused-imports", "warn about unnecessary imports"),+    ("unused-matches", "warn about variables in patterns that aren't used")+    ]++----------------+-- Warning monad+----------------++{-# NOINLINE ioWarnings #-}+ioWarnings :: IORef [Warning]+ioWarnings = unsafePerformIO $ newIORef []++instance MonadWarn IO where+    addWarning w = modifyIORef ioWarnings (w:)+instance MonadWarn (Writer [Warning]) where+    addWarning w = tell [w]+instance MonadWarn Identity+instance MonadWarn m => MonadWarn (ReaderT a m) where+    addWarning w = lift $ addWarning w
+ src/GenUtil.hs view
@@ -0,0 +1,761 @@+--  $Id: GenUtil.hs,v 1.53 2009/06/04 04:39:15 john Exp $+-- arch-tag: 835e46b7-8ffd-40a0-aaf9-326b7e347760++-- Copyright (c) 2002 John Meacham (john@foo.net)+--+-- Permission is hereby granted, free of charge, to any person obtaining a+-- copy of this software and associated documentation files (the+-- "Software"), to deal in the Software without restriction, including+-- without limitation the rights to use, copy, modify, merge, publish,+-- distribute, sublicense, and/or sell copies of the Software, and to+-- permit persons to whom the Software is furnished to do so, subject to+-- the following conditions:+--+-- The above copyright notice and this permission notice shall be included+-- in all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.++----------------------------------------+-- | This is a collection of random useful utility functions written in pure+-- Haskell 98. In general, it trys to conform to the naming scheme put forth+-- the haskell prelude and fill in the obvious omissions, as well as provide+-- useful routines in general. To ensure maximum portability, no instances are+-- exported so it may be added to any project without conflicts.+----------------------------------------++module GenUtil(+    -- * Functions+    -- ** Error reporting+    putErr,putErrLn,putErrDie,+    -- ** Simple deconstruction+    fromLeft,fromRight,fsts,snds,splitEither,rights,lefts,+    isLeft,isRight,+    fst3,snd3,thd3,+    -- ** System routines+    exitSuccess, exitFailure, epoch, lookupEnv,endOfTime,+    -- ** Random routines+    repMaybe,+    liftT2, liftT3, liftT4,+    snub, snubFst, snubUnder, smerge, sortFst, groupFst, foldl',+    fmapLeft,fmapRight,isDisjoint,isConjoint,+    groupUnder,+    sortUnder,+    minimumUnder,+    maximumUnder,+    sortGroupUnder,+    sortGroupUnderF,+    sortGroupUnderFG,+    sameLength,+    naturals,++    -- ** Monad routines+    perhapsM,+    repeatM, repeatM_, replicateM, replicateM_, maybeToMonad,+    toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_,+    maybeM,+    -- ** Text Routines+    -- *** Quoting+    shellQuote, simpleQuote, simpleUnquote,+    -- *** Layout+    indentLines,+    buildTableLL,+    buildTableRL,+    buildTable,+    trimBlankLines,+    paragraph,+    paragraphBreak,+    expandTabs,+    chunkText,+    -- *** Scrambling+    rot13,+    -- ** Random+    intercalate,+    powerSet,+    randomPermute,+    randomPermuteIO,+    chunk,+    rtup,+    triple,+    fromEither,+    mapFst,+    mapSnd,+    mapFsts,+    mapSnds,+    tr,+    readHex,+    overlaps,+    showDuration,+    readM,+    readsM,+    split,+    tokens,+    count,+    hasRepeatUnder,+    -- ** Option handling+    getArgContents,+    parseOpt,+    getOptContents,+    doTime,+    getPrefix,+    rspan,+    rbreak,+    rdropWhile,+    rtakeWhile,+    rbdropWhile,+    concatMapM,+    on,+    mapMsnd,+    mapMfst,+    iocatch,++    -- * Classes+    UniqueProducer(..)+    ) where++import Data.Char(isAlphaNum, isSpace, toLower, ord, chr)+import Data.List+import Control.Monad (join, liftM, MonadPlus, mzero)+import qualified System.IO as IO+import System.IO.Error (isDoesNotExistError)+import Control.Exception+import Prelude hiding (catch)+import System.Random(StdGen, newStdGen, Random(randomR))+import System.Time+import System.CPUTime+import System.Exit+import System.Environment++{-# SPECIALIZE snub :: [String] -> [String] #-}+{-# SPECIALIZE snub :: [Int] -> [Int] #-}++{-# RULES "snub/snub" forall x . snub (snub x) = snub x #-}+{-# RULES "snub/nub" forall x . snub (nub x) = snub x #-}+{-# RULES "nub/snub" forall x . nub (snub x) = snub x #-}+{-# RULES "snub/sort" forall x . snub (sort x) = snub x #-}+{-# RULES "sort/snub" forall x . sort (snub x) = snub x #-}+{-# RULES "snub/[]" snub [] = [] #-}+{-# RULES "snub/[x]" forall x . snub [x] = [x] #-}++-- | catch function only for IOException+iocatch :: IO a -> (IOException -> IO a) -> IO a+iocatch = catch++-- | sorted nub of list, much more efficient than nub, but doesnt preserve ordering.+snub :: Ord a => [a] -> [a]+snub = map head . group . sort++-- | sorted nub of list of tuples, based solely on the first element of each tuple.+snubFst :: Ord a => [(a,b)] -> [(a,b)]+snubFst = map head . groupBy (\(x,_) (y,_) -> x == y) . sortBy (\(x,_) (y,_) -> compare x y)++-- | sorted nub of list based on function of values+snubUnder :: Ord b => (a -> b) -> [a] -> [a]+snubUnder f = map head . groupUnder f . sortUnder f++-- | sort list of tuples, based on first element of each tuple.+sortFst :: Ord a => [(a,b)] -> [(a,b)]+sortFst = sortBy (\(x,_) (y,_) -> compare x y)++-- | group list of tuples, based only on equality of the first element of each tuple.+groupFst :: Eq a => [(a,b)] -> [[(a,b)]]+groupFst = groupBy (\(x,_) (y,_) -> x == y)++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = do+    res <- mapM f xs+    return $ concat res++on :: (a -> a -> b) -> (c -> a) -> c -> c -> b+(*) `on` f = \x y -> f x * f y++mapMsnd :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]+mapMsnd f xs = do+    let g (a,b) = do+            c <- f b+            return (a,c)+    mapM g xs++mapMfst :: Monad m => (b -> m c) -> [(b,a)] -> m [(c,a)]+mapMfst f xs = do+    let g (a,b) = do+            c <- f a+            return (c,b)+    mapM g xs++rspan :: (a -> Bool) -> [a] -> ([a], [a])+rspan fn xs = f xs [] where+    f [] rs = ([],reverse rs)+    f (x:xs) rs+        | fn x = f xs (x:rs)+        | otherwise = (reverse rs ++ x:za,zb) where+            (za,zb) = f xs []++rbreak :: (a -> Bool) -> [a] -> ([a], [a])+rbreak fn xs = rspan (not . fn) xs++rdropWhile :: (a -> Bool) -> [a] -> [a]+rdropWhile fn xs = f xs [] where+    f [] _ = []+    f (x:xs) rs+        | fn x = f xs (x:rs)+        | otherwise = reverse rs ++ x:(f xs [])++rtakeWhile :: (a -> Bool) -> [a] -> [a]+rtakeWhile fn xs = f xs [] where+    f [] rs = reverse rs+    f (x:xs) rs+        | fn x = f xs (x:rs)+        | otherwise = f xs []++rbdropWhile :: (a -> Bool) -> [a] -> [a]+rbdropWhile fn xs = rdropWhile fn (dropWhile fn xs)++-- | group a list based on a function of the values.+groupUnder :: Eq b => (a -> b) -> [a] -> [[a]]+groupUnder f = groupBy (\x y -> f x == f y)+-- | sort a list based on a function of the values.+sortUnder :: Ord b => (a -> b) -> [a] -> [a]+sortUnder f = sortBy (\x y -> f x `compare` f y)++-- | merge sorted lists in linear time+smerge :: Ord a => [a] -> [a] -> [a]+smerge (x:xs) (y:ys)+    | x == y = x:smerge xs ys+    | x < y = x:smerge xs (y:ys)+    | otherwise = y:smerge (x:xs) ys+smerge [] ys = ys+smerge xs [] = xs++sortGroupUnder :: Ord a => (b -> a) -> [b] -> [[b]]+sortGroupUnder f = groupUnder f . sortUnder f+sortGroupUnderF :: Ord a => (b -> a) -> [b] -> [(a,[b])]+sortGroupUnderF f xs = [ (f x, xs) |  xs@(x:_) <- sortGroupUnder f xs]++sortGroupUnderFG :: Ord b => (a -> b) -> (a -> c) -> [a] -> [(b,[c])]+sortGroupUnderFG f g xs = [ (f x, map g xs) |  xs@(x:_) <- sortGroupUnder f xs]++minimumUnder :: Ord b => (a -> b) -> [a] -> a+minimumUnder _ [] = error "minimumUnder: empty list"+minimumUnder _ [x] = x+minimumUnder f (x:xs) = g (f x) x xs where+    g _ x [] = x+    g fb b (x:xs)+        | fx < fb = g fx x xs+        | otherwise = g fb b xs where+            fx = f x++maximumUnder :: Ord b => (a -> b) -> [a] -> a+maximumUnder _ [] = error "maximumUnder: empty list"+maximumUnder _ [x] = x+maximumUnder f (x:xs) = g (f x) x xs where+    g _ x [] = x+    g fb b (x:xs)+        | fx > fb = g fx x xs+        | otherwise = g fb b xs where+            fx = f x++-- | Flushes stdout and writes string to standard error+putErr :: String -> IO ()+putErr s = IO.hFlush IO.stdout >> IO.hPutStr IO.stderr s++-- | Flush stdout and write string and newline to standard error+putErrLn :: String -> IO ()+putErrLn s = IO.hFlush IO.stdout >> IO.hPutStrLn IO.stderr s++-- | Flush stdout, write string and newline to standard error,+-- then exit program with failure.+putErrDie :: String -> IO a+putErrDie s = putErrLn s >> exitFailure++{-# INLINE fromRight #-}+fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "fromRight"++{-# INLINE fromLeft #-}+fromLeft :: Either a b -> a+fromLeft (Left x) = x+fromLeft _ = error "fromLeft"++-- | recursivly apply function to value until it returns Nothing+repMaybe :: (a -> Maybe a) -> a -> a+repMaybe f e = case f e of+    Just e' -> repMaybe f e'+    Nothing -> e++{-# INLINE liftT2 #-}+{-# INLINE liftT3 #-}+{-# INLINE liftT4 #-}++liftT4 (f1,f2,f3,f4) (v1,v2,v3,v4) = (f1 v1, f2 v2, f3 v3, f4 v4)+liftT3 (f,g,h) (x,y,z) = (f x, g y, h z)+-- | apply functions to values inside a tupele. 'liftT3' and 'liftT4' also exist.+liftT2 :: (a -> b, c -> d) -> (a,c) -> (b,d)+liftT2 (f,g) (x,y) = (f x, g y)++-- | class for monads which can generate+-- unique values.+class Monad m => UniqueProducer m where+    -- | produce a new unique value+    newUniq :: m Int++rtup a b = (b,a)+triple a b c = (a,b,c)++fst3 (a,_,_) = a+snd3 (_,b,_) = b+thd3 (_,_,c) = c++-- | the standard unix epoch+epoch :: ClockTime+epoch = toClockTime $ CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined}++-- | an arbitrary time in the future+endOfTime :: ClockTime+endOfTime = toClockTime $ CalendarTime { ctYear = 2020, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined}++{-# INLINE fsts #-}+-- | take the fst of every element of a list+fsts :: [(a,b)] -> [a]+fsts = map fst++{-# INLINE snds #-}+-- | take the snd of every element of a list+snds :: [(a,b)] -> [b]+snds = map snd++{-# INLINE repeatM #-}+{-# SPECIALIZE repeatM :: IO a -> IO [a] #-}+repeatM :: Monad m => m a -> m [a]+repeatM x = sequence $ repeat x++{-# INLINE repeatM_ #-}+{-# SPECIALIZE repeatM_ :: IO a -> IO () #-}+repeatM_ :: Monad m => m a -> m ()+repeatM_ x = sequence_ $ repeat x++{-# RULES "replicateM/0" replicateM 0 = const (return []) #-}+{-# RULES "replicateM_/0" replicateM_ 0 = const (return ()) #-}++{-# INLINE replicateM #-}+{-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-}+replicateM :: Monad m => Int -> m a -> m [a]+replicateM n x = sequence $ replicate n x++{-# INLINE replicateM_ #-}+{-# SPECIALIZE replicateM_ :: Int -> IO a -> IO () #-}+replicateM_ :: Monad m => Int -> m a -> m ()+replicateM_ n x = sequence_ $ replicate n x++-- | convert a maybe to an arbitrary failable monad+maybeToMonad :: Monad m => Maybe a -> m a+maybeToMonad (Just x) = return x+maybeToMonad Nothing = fail "Nothing"++-- | convert a maybe to an arbitrary failable monad+maybeM :: Monad m => String -> Maybe a -> m a+maybeM _ (Just x) = return x+maybeM s Nothing = fail s++toMonadM :: Monad m => m (Maybe a) -> m a+toMonadM action = join $ liftM maybeToMonad action++foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a+foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs+foldlM _ v [] = return v++foldl1M :: Monad m => (a -> a -> m a) ->  [a] -> m a+foldl1M f (x:xs) = foldlM f x xs+foldl1M _ _ = error "foldl1M"++foldlM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m ()+foldlM_ f v xs = foldlM f v xs >> return ()++foldl1M_ ::Monad m => (a -> a -> m a)  -> [a] -> m ()+foldl1M_ f xs = foldl1M f xs >> return ()++-- | partition a list of eithers.+splitEither :: [Either a b] -> ([a],[b])+splitEither  (r:rs) = case splitEither rs of+    (xs,ys) -> case r of+        Left x -> (x:xs,ys)+        Right y -> (xs,y:ys)+splitEither          [] = ([],[])++isLeft Left {} = True+isLeft _ = False++isRight Right {} = True+isRight _ = False++perhapsM :: Monad m => Bool -> a -> m a+perhapsM True a = return a+perhapsM False _ = fail "perhapsM"++sameLength (_:xs) (_:ys) = sameLength xs ys+sameLength [] [] = True+sameLength _ _ = False++fromEither :: Either a a -> a+fromEither (Left x) = x+fromEither (Right x) = x++{-# INLINE mapFst #-}+{-# INLINE mapSnd #-}+mapFst :: (a -> b) -> (a,c) -> (b,c)+mapFst  f   (x,y) = (f x,  y)+mapSnd :: (a -> b) -> (c,a) -> (c,b)+mapSnd    g (x,y) = (  x,g y)++{-# INLINE mapFsts #-}+{-# INLINE mapSnds #-}+mapFsts :: (a -> b) -> [(a,c)] -> [(b,c)]+mapFsts f xs = [(f x, y) | (x,y) <- xs]+mapSnds :: (a -> b) -> [(c,a)] -> [(c,b)]+mapSnds g xs = [(x, g y) | (x,y) <- xs]++{-# INLINE rights #-}+-- | take just the rights+rights :: [Either a b] -> [b]+rights xs = [x | Right x <- xs]++{-# INLINE lefts #-}+-- | take just the lefts+lefts :: [Either a b] -> [a]+lefts xs = [x | Left x <- xs]++-- | Trasform IO errors into the failing of an arbitrary monad.+ioM :: Monad m => IO a -> IO (m a)+ioM action = iocatch (fmap return action) (\e -> return (fail (show e)))++-- | Trasform IO errors into the mzero of an arbitrary member of MonadPlus.+ioMp :: MonadPlus m => IO a -> IO (m a)+ioMp action = iocatch (fmap return action) (\_ -> return mzero)++-- | reformat a string to not be wider than a given width, breaking it up+-- between words.++paragraph :: Int -> String -> String+paragraph maxn xs = drop 1 (f maxn (words xs)) where+    f n (x:xs) | lx < n = (' ':x) ++ f (n - lx) xs where+        lx = length x + 1+    f _ (x:xs) = '\n': (x ++ f (maxn - length x) xs)+    f _ [] = "\n"++chunk :: Int -> [a] -> [[a]]+chunk 0 _  = repeat []+chunk _ [] = []+chunk mw s = case splitAt mw s of+    (a,[]) -> [a]+    (a,b) -> a : chunk mw b++chunkText :: Int -> String -> String+chunkText mw s = concatMap (unlines . chunk mw) $ lines s++rot13Char :: Char -> Char+rot13Char c+    | c >= 'a' && c <= 'm' || c >= 'A' && c <= 'M' = chr $ ord c + 13+    | c >= 'n' && c <= 'z' || c >= 'N' && c <= 'Z' = chr $ ord c - 13+    | otherwise                                    = c++rot13 :: String -> String+rot13 = map rot13Char++{-+paragraphBreak :: Int -> String -> String+paragraphBreak  maxn xs = unlines (map ( unlines . map (unlines . chunk maxn) . lines . f maxn ) $ lines xs) where+    f _ "" = ""+    f n xs | length ss > 0 = if length ss + r rs > n then '\n':f maxn rs else ss where+        (ss,rs) = span isSpace xs+    f n xs = ns ++ f (n - length ns) rs where+        (ns,rs) = span (not . isSpace) xs+    r xs = length $ fst $ span (not . isSpace) xs+-}++paragraphBreak :: Int -> String -> String+paragraphBreak  maxn xs = unlines $ (map f) $ lines xs where+    f s | length s <= maxn = s+    f s | isSpace (head b) = a ++ "\n" ++ f (dropWhile isSpace b)+        | all (not . isSpace) a = a ++ "\n" ++ f b+        | otherwise  = reverse (dropWhile isSpace sa) ++ "\n" ++ f (reverse ea ++ b) where+            (ea, sa) = span (not . isSpace) $ reverse a+            (a,b) = splitAt maxn s++expandTabs' :: Int -> Int -> String -> String+expandTabs' 0 _ s = filter (/= '\t') s+expandTabs' sz off ('\t':s) = replicate len ' ' ++ expandTabs' sz (off + len) s where+    len = (sz - (off `mod` sz))+expandTabs' sz _ ('\n':s) = '\n': expandTabs' sz 0 s+expandTabs' sz off (c:cs) = c: expandTabs' sz (off + 1) cs+expandTabs' _ _ "" = ""++-- | expand tabs into spaces in a string assuming tabs are every 8 spaces and we are starting at column 0.+expandTabs :: String -> String+expandTabs s = expandTabs' 8 0 s++-- | Translate characters to other characters in a string, if the second argument is empty,+-- delete the characters in the first argument, else map each character to the+-- cooresponding one in the second argument, cycling the second argument if+-- necessary.++tr :: String -> String -> String -> String+tr as "" s = filter (`notElem` as) s+tr as bs s = map (f as bs) s where+    f (a:_) (b:_) c | a == c = b+    f (_:as) (_:bs) c = f as bs c+    f [] _ c = c+    f as' [] c = f as' bs c+    --f _ _ _ = error "invalid tr"++-- | quote strings rc style. single quotes protect any characters between+-- them, to get an actual single quote double it up. Inverse of 'simpleUnquote'+simpleQuote :: [String] -> String+simpleQuote ss = unwords (map f ss) where+    f s | any isBad s || null s = "'" ++ dquote s ++ "'"+    f s = s+    dquote s = concatMap (\c -> if c == '\'' then "''" else [c]) s+    isBad c = isSpace c || c == '\''++-- | inverse of 'simpleQuote'+simpleUnquote :: String -> [String]+simpleUnquote s = f (dropWhile isSpace s)  where+    f [] = []+    f ('\'':xs) = case quote' "" xs of (x,y) ->  x:f (dropWhile isSpace y)+    f xs = case span (not . isSpace) xs of (x,y) ->  x:f (dropWhile isSpace y)+    quote' a ('\'':'\'':xs) = quote' ('\'':a) xs+    quote' a ('\'':xs) = (reverse a, xs)+    quote' a (x:xs) = quote' (x:a) xs+    quote' a [] = (reverse a, "")++-- | quote a set of strings as would be appropriate to pass them as+-- arguments to a sh style shell+shellQuote :: [String] -> String+shellQuote ss = unwords (map f ss) where+    f s | any (not . isGood) s || null s  = "'" ++ dquote s ++ "'"+    f s = s+    dquote s = concatMap (\c -> if c == '\'' then "'\\''" else [c]) s+    isGood c = isAlphaNum c || c `elem` "@/.-_:"++-- | looks up an enviornment variable and returns it in an arbitrary Monad rather+-- than raising an exception if the variable is not set.+lookupEnv :: Monad m => String -> IO (m String)+lookupEnv s = catch (fmap return $ getEnv s) (\e -> if isDoesNotExistError e then return (fail (show e)) else ioError e)++{-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-}+fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b)+fmapLeft fn = fmap f where+    f (Left x) = Left (fn x)+    f (Right x)  = Right x++{-# SPECIALIZE fmapRight :: (b -> c) -> [(Either a b)] -> [(Either a c)] #-}+fmapRight :: Functor f => (b -> c) -> f (Either a b) -> f (Either a c)+fmapRight fn = fmap f where+    f (Left x) = Left x+    f (Right x)  = Right (fn x)++{-# SPECIALIZE isDisjoint :: [String] -> [String] -> Bool #-}+{-# SPECIALIZE isConjoint :: [String] -> [String] -> Bool #-}+{-# SPECIALIZE isDisjoint :: [Int] -> [Int] -> Bool #-}+{-# SPECIALIZE isConjoint :: [Int] -> [Int] -> Bool #-}+-- | set operations on lists. (slow!)+isDisjoint, isConjoint :: Eq a => [a] -> [a] -> Bool+isConjoint xs ys = or [x == y | x <- xs, y <- ys]+isDisjoint xs ys = not (isConjoint xs ys)++-- | place spaces before each line in string.+indentLines :: Int -> String -> String+indentLines n s = unlines $ map (replicate n ' ' ++)$ lines s++-- | trim blank lines at beginning and end of string+trimBlankLines :: String -> String+trimBlankLines cs = unlines $ rbdropWhile (all isSpace) (lines cs)++buildTableRL :: [(String,String)] -> [String]+buildTableRL ps = map f ps where+    f (x,"") = x+    f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y+    bs = maximum (map (length . fst) [ p | p@(_,_:_) <- ps ])++buildTableLL :: [(String,String)] -> [String]+buildTableLL ps = map f ps where+    f (x,y) = x ++ replicate (bs - length x) ' ' ++ replicate 4 ' ' ++ y+    bs = maximum (map (length . fst) ps)++-- | count elements of list that have a given property+count :: (a -> Bool) -> [a] -> Int+count f xs = g 0 xs where+    g n [] = n+    g n (x:xs)+        | f x = let x = n + 1 in x `seq` g x xs+        | otherwise = g n xs++-- | randomly permute a list, using the standard random number generator.+randomPermuteIO :: [a] -> IO [a]+randomPermuteIO xs = newStdGen >>= \g -> return (randomPermute g xs)++-- | randomly permute a list given a RNG+randomPermute :: StdGen -> [a] -> [a]+randomPermute _   []  = []+randomPermute gen xs  = (head tl) : randomPermute gen' (hd ++ tail tl)+   where (idx, gen') = randomR (0,length xs - 1) gen+         (hd,  tl)   = splitAt idx xs++hasRepeatUnder f xs = any (not . null . tail) $ sortGroupUnder f xs++-- | compute the power set of a list++powerSet       :: [a] -> [[a]]+powerSet []     = [[]]+powerSet (x:xs) = xss /\/ map (x:) xss+                where xss = powerSet xs++-- | interleave two lists lazily, alternating elements from them. This can also be+-- used instead of concatination to avoid space leaks in certain situations.++(/\/)        :: [a] -> [a] -> [a]+[]     /\/ ys = ys+(x:xs) /\/ ys = x : (ys /\/ xs)++readHexChar a | a >= '0' && a <= '9' = return $ ord a - ord '0'+readHexChar a | z >= 'a' && z <= 'f' = return $ 10 + ord z - ord 'a' where z = toLower a+readHexChar x = fail $ "not hex char: " ++ [x]++readHex :: Monad m => String -> m Int+readHex [] = fail "empty string"+readHex cs = mapM readHexChar cs >>= \cs' -> return (rh $ reverse cs') where+    rh (c:cs) =  c + 16 * (rh cs)+    rh [] =  0++{-# SPECIALIZE overlaps :: (Int,Int) -> (Int,Int) -> Bool #-}++-- | determine if two closed intervals overlap at all.++overlaps :: Ord a => (a,a) -> (a,a) -> Bool+(a,_) `overlaps` (_,y) | y < a = False+(_,b) `overlaps` (x,_) | b < x = False+_ `overlaps` _ = True++-- | translate a number of seconds to a string representing the duration expressed.+showDuration :: (Show a,Integral a) => a -> String+showDuration x = st "d" dayI ++ st "h" hourI ++ st "m" minI ++ show secI ++ "s" where+        (dayI, hourI) = divMod hourI' 24+        (hourI', minI) = divMod minI' 60+        (minI',secI) = divMod x 60+        st _ 0 = ""+        st c n = show n ++ c++-- | behave like while(<>) in perl, go through the argument list, reading the+-- concation of each file name mentioned or stdin if '-' is on it. If no+-- arguments are given, read stdin.++getArgContents :: IO String+getArgContents = do+    as <- getArgs+    let f "-" = getContents+        f fn = readFile fn+    cs <- mapM f as+    if null as then getContents else return $ concat cs++-- | Combination of parseOpt and getArgContents.+getOptContents :: String -> IO (String,[Char],[(Char,String)])+getOptContents args = do+    as <- getArgs+    (as,o1,o2) <- parseOpt args as+    let f "-" = getContents+        f fn = readFile fn+    cs <- mapM f as+    s <- if null as then getContents else return $ concat cs+    return (s,o1,o2)++-- | Process options with an option string like the standard C getopt function call.+parseOpt :: Monad m =>+    String -- ^ Argument string, list of valid options with : after ones which accept an argument+    -> [String]  -- ^ Arguments+    -> m ([String],[Char],[(Char,String)])  -- ^ (non-options,flags,options with arguments)+parseOpt ps as = f ([],[],[]) as where+    (args,oargs) = g ps [] [] where+        g (':':_) _ _ = error "getOpt: Invalid option string"+        g (c:':':ps) x y = g ps x (c:y)+        g (c:ps) x y = g ps (c:x) y+        g [] x y = (x,y)+    f cs [] = return cs+    f (xs,ys,zs) ("--":rs) = return (xs ++ rs, ys, zs)+    f cs (('-':as@(_:_)):rs) = z cs as where+        z (xs,ys,zs) (c:cs)+            | c `elem` args = z (xs,c:ys,zs) cs+            | c `elem` oargs = case cs of+                [] -> case rs of+                    (x:rs) -> f (xs,ys,(c,x):zs) rs+                    [] -> fail $ "Option requires argument: " ++ [c]+                x -> f (xs,ys,(c,x):zs) rs+            | otherwise = fail $ "Invalid option: " ++ [c]+        z cs [] = f cs rs+    f (xs,ys,zs) (r:rs) = f (xs ++ [r], ys, zs) rs++readM :: (Monad m, Read a) => String -> m a+readM cs = case [x | (x,t) <-  reads cs, ("","") <- lex t] of+    [x] -> return x+    [] -> fail "readM: no parse"+    _ -> fail "readM: ambiguous parse"++readsM :: (Monad m, Read a) => String -> m (a,String)+readsM cs = case readsPrec 0 cs of+    [(x,s)] -> return (x,s)+    _ -> fail "cannot readsM"++-- | Splits a list into components delimited by separators, where the+-- predicate returns True for a separator element.  The resulting+-- components do not contain the separators.  Two adjacent separators+-- result in an empty component in the output.  eg.+--+-- > split (=='a') "aabbaca"+-- > ["", "", "bb", "c", ""]+--+split :: (a -> Bool) -> [a] -> [[a]]+split p s = case rest of+                []     -> [chunk]+                _:rest -> chunk : split p rest+  where (chunk, rest) = break p s++-- | Like 'split', except that sequences of adjacent separators are+-- treated as a single separator. eg.+--+--   > tokens (=='a') "aabbaca"+--   > ["bb","c"]+tokens :: (a -> Bool) -> [a] -> [[a]]+tokens p = filter (not.null) . split p++buildTable ::  [String] -> [(String,[String])] -> String+buildTable ts rs = bt [ x:xs | (x,xs) <- ("",ts):rs ] where+    bt ts = unlines (map f ts) where+        f xs = intercalate " " (zipWith es cw xs)+        cw = [ maximum (map length xs) | xs <- transpose ts]+    es n s = replicate (n - length s) ' ' ++ s++-- | time task+doTime :: String -> IO a -> IO a+doTime str action = do+    start <- getCPUTime+    x <- action+    end <- getCPUTime+    putStrLn $ "Timing: " ++ str ++ " " ++ show ((end - start) `div` cpuTimePrecision)+    return x++getPrefix :: Monad m => String -> String -> m String+getPrefix a b = f a b where+    f [] ss = return ss+    f _  [] = fail "getPrefix: value too short"+    f (p:ps) (s:ss)+        | p == s = f ps ss+        | otherwise = fail $ "getPrefix: " ++ a ++ " " ++ b++{-# INLINE naturals #-}+naturals :: [Int]+naturals = [0..]
+ src/Grin/Arity.hs view
@@ -0,0 +1,45 @@+module Grin.Arity(grinRaiseArity) where++import IO(stdout)+import qualified Data.Map as Map++import Fixer.Fixer+import Fixer.Supply+import GenUtil+import Grin.Grin+import Support.FreeVars+import Support.ShowTable++grinRaiseArity :: Grin -> IO Grin+grinRaiseArity grin = do+    fixer <- newFixer+    argSupply <- newSupply fixer++    mapM_ (go argSupply) (grinFunctions grin)++    findFixpoint (Just ("grin arity raising",stdout)) fixer++    rv <- supplyReadValues argSupply+    printTable "Grin.Arity: arguments" rv++    return grin++go argSupply (fn,~(Tup as) :-> e) = do+    vs <- mapM (\ (Var v _,i) -> supplyValue argSupply (fn,i)) (zip as naturals)+    let env = Map.fromList (zip [ v | ~(Var v _) <- as ] vs)+        f Fetch {} = return ()+        f (App n as _) = mapM_ (g n) (zip as naturals)+        f (Store (NodeC nn as)) | Just (_,n) <- tagUnfunction nn = mapM_ (g n) (zip as naturals)+        f (e1 :>>= p :-> e2) = f e1 >> f e2+        f (Case x as) = mapM_ bf (freeVars x) >> sequence_ [ f e  | _ :-> e <- as]+        f e = mapM_ bf (freeVars e)+        g fn (Var v _,i) | Just value <- Map.lookup v env = do+            vv <- supplyValue argSupply (fn,i)+            addRule $ vv `implies` value+        g _ _ = return ()+        bf v | Just val <- Map.lookup v env = addRule $ value True `implies` val+        bf _ = return ()+    f e++implies :: Value Bool -> Value Bool -> Rule+implies x y = y `isSuperSetOf` x
+ src/Grin/DeadCode.hs view
@@ -0,0 +1,235 @@+{-# OPTIONS -XNoMonoLocalBinds #-}+module Grin.DeadCode(deadCode) where++import Control.Monad+import Control.Monad.Trans (MonadIO)+import Data.Monoid+import qualified Data.Set as Set++import Fixer.Fixer+import Fixer.Supply+import Grin.Grin+import Grin.Noodle+import Grin.Whiz+import Stats hiding(print, singleton)+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Gen+import Util.SetLike hiding(Value)++implies :: Value Bool -> Value Bool -> Rule+implies x y = y `isSuperSetOf` x++-- | Remove dead code from Grin.+deadCode ::+    Stats.Stats   -- ^ stats to update with what was done+    -> [Atom]  -- ^ roots+    -> Grin    -- ^ input+    -> IO Grin -- ^ output+deadCode stats roots grin = do+    fixer <- newFixer+    usedFuncs <- newSupply fixer+    usedArgs <- newSupply fixer+    usedCafs <- newSupply fixer+    pappFuncs <- newValue fixer bottom+    suspFuncs <- newValue fixer bottom+    -- set all roots as used+    flip mapM_ roots $ \r -> do+        addRule $ value True `implies` sValue usedFuncs r+    let postInline = phaseEvalInlined (grinPhase grin)++    forM_ (grinCafs grin) $ \ (v,NodeC t []) -> do+        (0,fn) <- tagUnfunction t+        v' <- supplyValue usedCafs v+        addRule $ conditionalRule id v' $ (suspFuncs `isSuperSetOf` value (singleton fn))+        addRule $ v' `implies` (sValue usedFuncs fn)++    mapM_ (go fixer pappFuncs suspFuncs usedFuncs usedArgs usedCafs postInline) (grinFuncs grin)+    findFixpoint Nothing {-"Dead Code"-} fixer+    ua <- supplyReadValues usedArgs+    uc <- supplyReadValues usedCafs+    uf <- supplyReadValues usedFuncs+    pappFuncs <- readValue pappFuncs+    suspFuncs <- readValue suspFuncs+    when False $ do+        putStrLn "usedArgs"+        mapM_ print ua+        putStrLn "usedCafs"+        mapM_ print uc+        putStrLn "usedFuncs"+        mapM_ print uf+        putStrLn "pappFuncs"+        print pappFuncs+        putStrLn "suspFuncs"+        print suspFuncs+    let cafSet = fg uc+        funSet = fg uf+        argSet = fg ua+                 `union`+                 fromList [ (n,i) | FuncDef n (args :-> _) _ _ <- grinFunctions grin,+                                        n `member` grinEntryPoints grin,+                                        i <- [0 .. length args] ]+        directFuncs =  funSet \\ suspFuncs \\ pappFuncs+        fg xs = fromList [ x | (x,True) <- xs ]+    newCafs <- flip mconcatMapM (grinCafs grin) $ \ (x,y) -> if x `member` cafSet then return [(x,y)] else tick stats "Optimize.dead-code.caf" >> return []+    let f ((x,y):xs) rs ws = do+            if not $ x `member` funSet then tick stats "Optimize.dead-code.func" >> f xs rs ws else do+            (ws',r) <- runStatIO stats $ removeDeadArgs postInline funSet directFuncs cafSet argSet (x,y) ws+            f xs (r:rs) ws'+        f [] rs _ = return rs+    newFuncs <- f (grinFuncs grin) [] whizState+    --newFuncs <- flip mconcatMapM (grinFuncs grin) $ \ (x,y) -> do+    let (TyEnv mp) = grinTypeEnv grin+    mp' <- flip mconcatMapM (toList mp) $ \ (x,tyty@TyTy { tySlots = ts }) -> case Just x  of+        Just _ | tagIsFunction x, not $ x `member` funSet -> return []+        Just fn | fn `member` directFuncs -> do+            let da (t,i)+                    | member (fn,i) argSet = return [t]+                    | otherwise = tick stats ("Optimize.dead-code.arg-func.{" ++ show x ++ "-" ++ show i) >> return []+            ts' <- mconcatMapM da (zip ts naturals)+            return [(x,tyty { tySlots = ts' })]+        _ -> return [(x,tyty)]++    return $ setGrinFunctions newFuncs grin {+        grinCafs = newCafs,+        grinPartFunctions = pappFuncs,+        grinTypeEnv = TyEnv $ fromList mp',+        --grinArgTags = Map.fromList newArgTags,+        grinSuspFunctions = suspFuncs+        }++combineArgs :: a -> [b] -> [((a, Int), b)]+combineArgs fn as = [ ((fn,n),a) | (n,a) <- zip [0 :: Int ..] as]++go :: (MonadIO m, Collection b, Collection a, Fixable b, Fixable a,+       Elem b ~ Atom, Elem a ~ Atom) =>+      Fixer+      -> Value a+      -> Value b+      -> Supply Tag Bool+      -> Supply (Tag, Int) Bool+      -> Supply Var Bool+      -> Bool+      -> (Tag, Lam)+      -> m Lam+go fixer pappFuncs suspFuncs usedFuncs usedArgs usedCafs postInline (fn,as :-> body) = ans where+    goAgain = go fixer pappFuncs suspFuncs usedFuncs usedArgs usedCafs postInline+    ans = do+        usedVars <- newSupply fixer++        flip mapM_ (combineArgs fn as) $ \ (ap,Var v _) -> do+            x <- supplyValue usedArgs ap+            v <- supplyValue usedVars v+            addRule $ v `implies` x+        -- a lot of things are predicated on this so that CAFS are not held on to unnecesarily+        fn' <- supplyValue usedFuncs fn+        let varValue v | v < v0 = sValue usedCafs v+                       | otherwise = sValue usedVars v+            f e = g e >> return e+            g (BaseOp Eval [e]) =  addRule (doNode e)+            g (BaseOp Apply {} vs) =  addRule (mconcatMap doNode vs)+            g (Case e _) =  addRule (doNode e)+            g Prim { expArgs = as } = addRule (mconcatMap doNode as)+            g (App a vs _) = do+                addRule $ conditionalRule id fn' $ mconcat [ mconcatMap (implies (sValue usedArgs fn) . varValue) (freeVars a) | (fn,a) <- combineArgs a vs]+                addRule $ fn' `implies` sValue usedFuncs a+                addRule (mconcatMap doNode vs)+            g (BaseOp Overwrite [Var v _,n]) | v < v0 = do+                v' <- supplyValue usedCafs v+                addRule $ conditionalRule id v' $ doNode n+            g (BaseOp Overwrite [vv,n]) = addRule $ (doNode vv) `mappend` (doNode n)+            g (BaseOp PokeVal [vv,n]) = addRule $ (doNode vv) `mappend` (doNode n)+            g (BaseOp PeekVal [vv]) = addRule $ (doNode vv)+            g (BaseOp Promote [vv]) = addRule $ (doNode vv)+            g (BaseOp _ xs) = addRule $ mconcatMap doNode xs+            g Alloc { expValue = v, expCount = c, expRegion = r } = addRule $ doNode v `mappend` doNode c `mappend` doNode r+            g Let { expDefs = defs, expBody = body } = do+                mapM_ goAgain [ (name,bod) | FuncDef { funcDefBody = bod, funcDefName = name } <- defs]+                flip mapM_ (map funcDefName defs) $ \n -> do+                    --n' <- supplyValue usedFuncs n+                    --addRule $ fn' `implies` n'+                    return ()+            g Error {} = return ()+            -- TODO - handle function and case return values smartier.+            g (Return ns) = mapM_ (addRule . doNode) ns+            g x = error $ "deadcode.g: " ++ show x+            h' (p,e) = h (p,e) >> return (Just (p,e))+            h (p,BaseOp (StoreNode _) [v]) = addRule $ mconcat $ [ conditionalRule id  (varValue pv) (doNode v) | pv <- freeVars p]+            h (p,BaseOp Demote [v]) = addRule $ mconcat $ [ conditionalRule id  (varValue pv) (doNode v) | pv <- freeVars p]+            h (p,Alloc { expValue = v, expCount = c, expRegion = r }) = addRule $ mconcat $ [ conditionalRule id  (varValue pv) (doNode v `mappend` doNode c `mappend` doNode r) | pv <- freeVars p]+            h (p,Return vs) = mapM_ (h . \v -> (p,BaseOp Promote [v])) vs -- addRule $ mconcat $ [ conditionalRule id  (varValue pv) (doNode v) | pv <- freeVars p]+            h (p,BaseOp Promote [v]) = addRule $ mconcat $ [ conditionalRule id  (varValue pv) (doNode v) | pv <- freeVars p]+            h (p,e) = g e+            doNode (NodeC n as) | not postInline, Just (x,fn) <- tagUnfunction n  = let+                consts = (mconcatMap doNode as)+                usedfn = implies fn' (sValue usedFuncs fn)+                suspfn | x > 0 = conditionalRule id fn' (pappFuncs `isSuperSetOf` value (singleton fn))+                       | otherwise = conditionalRule id fn' (suspFuncs `isSuperSetOf` value (singleton fn))+                in mappend consts $ mconcat (usedfn:suspfn:[ mconcatMap (implies (sValue usedArgs fn) . varValue) (freeVars a) | (fn,a) <- combineArgs fn as])+            doNode x = doConst x `mappend` mconcatMap (implies fn' . varValue) (freeVars x)+            doConst _ | postInline  = mempty+            doConst (Const n) = doNode n+            doConst (NodeC n as) = mconcatMap doConst as+            doConst _ = mempty++        (nl,_) <- whiz (\_ -> id) h' f whizState (as :-> body)+        return nl++removeDeadArgs :: MonadStats m => Bool -> Set.Set Atom -> Set.Set Atom -> (Set.Set Var) -> (Set.Set (Atom,Int)) -> (Atom,Lam) -> WhizState -> m (WhizState,(Atom,Lam))+removeDeadArgs postInline funSet directFuncs usedCafs usedArgs (a,l) whizState =  whizExps f (margs a l) >>= \(l,ws) -> return (ws,(a,l)) where+    whizExps f l = whiz (\_ x -> x) (\(p,e) -> f e >>= \e' -> return  (Just (p,e'))) f whizState l+    margs fn (as :-> e) | a `Set.member` directFuncs = ((removeArgs fn as) :-> e)+    margs _ x = x+    f (App fn as ty)  = do+        as <- dff fn as+        as <- mapM clearCaf as+        return $ App fn as ty+    f (Return [NodeC fn as]) | Just fn' <- tagToFunction fn = do+        as <- dff' fn' as+        as <- mapM clearCaf as+        return $ Return [NodeC fn as]+    f (BaseOp (StoreNode False) [NodeC fn as]) |  Just fn' <- tagToFunction fn = do+        as <- dff' fn' as+        as <- mapM clearCaf as+        return $ BaseOp (StoreNode False) [NodeC fn as]+    f (BaseOp Overwrite [(Var v TyINode),_]) | deadCaf v = do+        mtick $ toAtom "Optimize.dead-code.caf-update"+        return $ Return []+    f (BaseOp Overwrite [p,NodeC fn as]) |  Just fn' <- tagToFunction fn = do+        as <- dff' fn' as+        as <- mapM clearCaf as+        return $ BaseOp Overwrite  [p,NodeC fn as]+--    f (Update (Var v TyINode) _) | deadCaf v = do+--        mtick $ toAtom "Optimize.dead-code.caf-update"+--        return $ Return []+--    f (Update p (NodeC fn as)) |  Just fn' <- tagToFunction fn = do+--        as <- dff' fn' as+--        as <- mapM clearCaf as+--        return $ Update p (NodeC fn as)+    f lt@Let { expDefs = defs }  = return $ updateLetProps lt { expDefs = defs' } where+        defs' = [ updateFuncDefProps df { funcDefBody = margs name body } | df@FuncDef { funcDefName = name, funcDefBody = body } <- defs, name `Set.member` funSet ]+    f x = return x+    dff' fn as | fn `member` directFuncs = return as+    dff' fn as = dff'' fn as+    dff fn as | fn `member` directFuncs = return (removeArgs fn as)+    dff fn as = dff'' fn as+    dff'' fn as | not (fn `member` funSet) = return as -- if function was dropped, we don't have argument use information.+    dff'' fn as = mapM df  (zip as naturals) where+        df (a,i) | not (deadVal a) && not (member (fn,i) usedArgs) = do+            mtick $ toAtom "Optimize.dead-code.func-arg"+            return $ properHole (getType a)+        df (a,_)  = return a+    clearCaf (Var v TyINode) | deadCaf v = do+        mtick $ toAtom "Optimize.dead-code.caf-arg"+        return (properHole TyINode)+    clearCaf (NodeC a xs) = do+        xs <- mapM clearCaf xs+        return $ NodeC a xs+    clearCaf (Index a b) = return Index `ap` clearCaf a `ap` clearCaf b+    clearCaf (Const a) = Const `liftM` clearCaf a+    clearCaf x = return x+    deadCaf v = v < v0 && not (v `member` usedCafs)+    deadVal (Lit 0 _) = True+    deadVal x = isHole x+    removeArgs fn as = concat [ perhapsM ((fn,i) `member` usedArgs) a | a <- as | i <- naturals ]
+ src/Grin/Devolve.hs view
@@ -0,0 +1,171 @@+module Grin.Devolve(twiddleGrin,devolveTransform) where++import Control.Monad.Identity+import Control.Monad.RWS+import Data.Functor+import Data.IORef+import Data.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set++import Grin.Grin+import Grin.Noodle+import Options (verbose,fopts)+import Support.FreeVars+import Support.Transform+import Util.Gen+import Util.SetLike+import qualified FlagOpts as FO++{-# NOINLINE devolveTransform #-}+devolveTransform = transformParms {+    transformDumpProgress = verbose,+    transformCategory = "Devolve",+    transformPass = "Grin",+    transformOperation = devolveGrin+    }++-- devolve grin into a form in which it can be readily converted into C code+-- This lifts any local functions which are ever called in a non-tail-calllike form+-- to the top level.++devolveGrin :: Grin -> IO Grin+devolveGrin grin = do+    col <- newIORef []+    let g (n,l :-> r) = f r >>= \r -> return (n,l :-> r)+        f lt@Let { expDefs = defs, expBody = body, .. } = do+            let iterZ :: Bool -> Map.Map Tag (Set.Set Val) -> [FuncDef] -> Map.Map Tag (Set.Set Val)+                iterZ b pmap (fd@FuncDef { funcDefName = name, funcDefBody = as :-> r }:fs) = iterZ (b || xs' /= xs) (Map.insert name xs pmap) fs where+                    xs = Set.unions $ xs':catMaybes [ Map.lookup t pmap | t <- Set.toList $ freeVars fd]+                    xs' = maybe Set.empty id (Map.lookup name pmap)+                iterZ True pmap [] = iterZ False pmap defs+                iterZ False pmap [] = pmap++                nndefs = [ fd | fd <- defs, funcDefName fd `Set.member` expNonNormal ]+                pmap = iterZ False (fromList [ (funcDefName fd, fromList [ Var x y | (x,y) <- Set.toList $ freeVars (funcDefBody fd), x > v0]) | fd <- nndefs ]) nndefs++                (nmaps,rmaps) = splitEither (map z defs)+                z fd@FuncDef { funcDefName = name, funcDefBody = as :-> r }+                    | name `Set.member` expNonNormal = Left ((name,(as ++ xs) :-> pr),xs)+                    | otherwise = Right fd { funcDefBody = as :-> pr }+                  where xs = maybe [] Set.toList $ Map.lookup name pmap+                        pr = runIdentity $ proc r+                proc (App a as t) | Just xs <- Map.lookup a pmap = return (App a (as ++ Set.toList xs) t)+                proc e = mapExpExp proc e+            --mapM_ print (Map.toList pmap)+            nmaps <- mapM (g . fst) nmaps+            modifyIORef col (++ nmaps)+            updateLetProps <$> mapExpExp f lt { expDefs = rmaps, expBody = runIdentity $ proc body }+        f e = mapExpExp f e+    nf <- mapM g (grinFuncs grin)+    lf <- readIORef col+    let ntenv = extendTyEnv [ createFuncDef False x y | (x,y) <- lf ] (grinTypeEnv grin)+    return $  setGrinFunctions (lf ++ nf) grin { grinPhase = PostDevolve, grinTypeEnv = ntenv }+    --if null lf then return ng else devolveGrin ng+    --if null lf then return ng else devolveGrin ng++-- twiddle does some final clean up before translation to C+-- it replaces unused arguments with 'v0' and adds GC notations++data Env = Env {+    envMap   :: Map.Map Var Var,+    envRoots :: Set.Set Val,+    envVar   :: Var+    }++newtype R a = R (RWS Env (Set.Set Var) () a)+    deriving(Monad,Functor,MonadReader Env,MonadWriter (Set.Set Var))++runR (R x) = fst $ evalRWS x Env { envRoots = mempty, envMap = mempty, envVar = v1 } ()++class Twiddle a where+    twiddle :: a -> R a+    twiddle a = return a++instance Twiddle Exp where+    twiddle = twiddleExp++instance Twiddle Val where+    twiddle = twiddleVal++instance Twiddle a => Twiddle [a] where+    twiddle xs = mapM twiddle xs++twiddleExp e = f e where+--    f (BaseOp Promote vs :>>= rest) = f (Return vs :>>= rest)+--    f (BaseOp Demote vs :>>= rest) = f (Return vs :>>= rest)+    f (x :>>= lam) | fopts FO.Jgc && isAllocing x = do+        roots <- asks envRoots+        let nroots = Set.fromList [ Var v t | (v,t) <- Set.toList (freeVars (if isUsing x then ([] :-> x :>>= lam) else lam)), isNode t, v > v0] Set.\\ roots+        local (\e -> e { envRoots = envRoots e `Set.union` nroots}) $ do+            ne <- return (:>>=) `ap` twiddle x `ap` twiddle lam+            return $ gcRoots (Set.toList nroots) ne+    f (x :>>= lam) = return (:>>=) `ap` twiddle x `ap` twiddle lam+    f l@Let {} = do+        ds <- twiddle (expDefs l)+        b <- twiddle (expBody l)+        return . updateLetProps $ l { expDefs = ds, expBody = b }+    f (Case v as) = return Case `ap` twiddle v `ap` twiddle as+    f x | fopts FO.Jgc && isUsing x && isAllocing x = do+        roots <- asks envRoots+        let nroots = Set.fromList [ Var v t | (v,t) <- Set.toList (freeVars x), isNode t, v > v0] Set.\\ roots+        local (\e -> e { envRoots = envRoots e `Set.union` nroots}) $ do+            ne <- mapExpVal twiddleVal x+            return $ gcRoots (Set.toList nroots) ne+    f n = do e <- mapExpVal twiddleVal n ; mapExpExp twiddle e++    isUsing (BaseOp StoreNode {} _) = True+    isUsing Alloc {} = True+    isUsing _ = False++    isAllocing (BaseOp StoreNode {} _) = True+    isAllocing (BaseOp Eval {} _) = True+    isAllocing (Return [Var {}]) = False+    isAllocing (Return [NodeC {}]) = True+    isAllocing App {} = True+    isAllocing Call {} = True+    isAllocing Let {} = True+    isAllocing (Case _ as) = any isAllocing [ b | _ :-> b <- as]+    isAllocing Alloc {} = True+    isAllocing (e :>>= _ :-> y) = isAllocing e || isAllocing y+    isAllocing _ = False++    gcRoots [] x = x+    gcRoots xs e = GcRoots xs e++    isNode TyNode = True+    isNode TyINode = True+    isNode (TyPtr TyNode) = True+    isNode (TyPtr TyINode) = True+    isNode _ = False++instance Twiddle Lam where+    twiddle (vs :-> y) = do+        let fvs = freeVars vs+        (y,uv) <- censor (Set.filter (`notElem` fvs)) $ listen (twiddle y)+        let fvp' = Map.fromList $ concatMap (\v -> if v `Set.member` uv then [] else [(v,v0)]) fvs+        vs <- censor (const mempty) . local (\e -> e { envMap = fvp' }) $ twiddle vs+        return (vs :-> y)+--    twiddle (vs :-> y) = do+--        cv <- asks envVar+--        let fvp = Map.fromList $ zip fvs [cv ..]+--            fvs = freeVars vs+--        local (\e -> e { envVar = head $ drop (length fvs) [cv .. ], envMap = fvp `Map.union` envMap e }) $ do+--        (y,uv) <- censor (Set.filter (`notElem` take (length fvs) [cv .. ])) $ listen (twiddle y)+--        let fvp' = fmap (\v -> if v `Set.member` uv then v else v0) fvp+--        vs <- censor (const mempty) . local (\e -> e { envMap = fvp' }) $ twiddle vs+--        return (vs :-> y)++twiddleGrin grin = grinFunctions_s fs' grin where+    fs' = runR . twiddle  $ grinFunctions grin++instance Twiddle FuncDef where+    twiddle = funcDefBody_uM twiddle++twiddleVal x = f x where+    f var@(Var v ty) = do+        em <- asks envMap+        case Map.lookup v em of+            Just n -> tell (Set.singleton n) >> return (Var n ty)+            Nothing -> tell (Set.singleton v) >> return var+    f x = mapValVal f x
+ src/Grin/Embed.hs view
@@ -0,0 +1,130 @@+module Grin.Embed((.>>=),(.>>),GG,VVar,TyNode,TyTag,TyPtr,TyRaw,embedTest) where++import Doc.Pretty+import GenUtil+import Grin.Grin+import Grin.Show+import StringTable.Atom+import Support.CanType+import Util.UniqueMonad++newtype GG = GG { unGG :: (Uniq Exp) }++data TyNode+data TyTag+data TyPtr a+data TyRaw a+data TyUnknown++runGG :: Int -> Uniq Exp -> Exp+runGG n x | n <= 0 = runGG 1 x+runGG s (GG x) = fst (runUniq s x)++unLam :: forall a . Valable a => ( a -> GG ) -> Uniq Lam+unLam f = do+    (x,v) <- varUp (error "cannot unlamunknown")+    gb <- unGG $ f x+    return $ v :-> gb++dunLam :: forall a . Valable a => Ty -> ( a -> GG ) -> Uniq Lam+dunLam ty f = do+    (x,v) <- varUp ty+    gb <- unGG $ f x+    return $ v :-> gb++{-+data TyTup -- ???+data Val :: * where+    Tag :: Tag -> Val TyTag+    Const :: Val x -> Val (TyPtr x)+    Lit :: Number -> Val (TyBasic)+    Var :: Var -> Val a+    NodeC :: Tag -> ???? -> Val TyNode+    Tup :: ???? -> Val ???+-}++infixr 1  .>>=, .>>++(.>>=) :: Valable a => GG -> (a -> GG) -> GG+(.>>=) (GG g1) f2 = GG $ do+    ga <- g1+    (x,v) <- varUp (getType ga)+    gb <- unGG $ f2 x+    return $ ga :>>= v :-> gb++(.>>) :: GG -> GG -> GG+(.>>) g1 g2 = g1 .>>= \ ( _ :: TyUnknown ) -> g2++newtype VVar a = VVar Val++class Valable a where+    varUp :: Ty -> Uniq (a,Val)++vvarUp :: forall a . Ty -> Uniq (VVar a,Val)+vvarUp TyTup {} = error "vvarUp tuple"+vvarUp ty = do+    vv <- newVal ty+    return (VVar vv,vv)++newVal (TyTup tys) = do+    vs <- mapM newVal tys+    return (Tup vs)+newVal ty = do+    i <- newUniq+    return (Var (V i) ty)++{-+instance Valable a where+    varUp ty = do+        vv <- newVal ty+        return (undefined,vv)+-}++instance Valable TyUnknown where+    varUp ty = do+        vv <- newVal ty+        return (undefined,vv)++instance TyBasic a => Valable (VVar (TyRaw a)) where+    varUp _ = vvarUp (Ty (rawType (undefined :: a)))++instance Valable (VVar TyNode) where+    varUp _ = vvarUp TyNode+instance Valable (VVar TyTag) where+    varUp _ = vvarUp TyTag+instance (Valable a, Valable b) => Valable (a,b) where+    varUp (TyTup [x,y]) = do+        (vva,va) <- varUp x+        (vvb,vb) <- varUp y+        return ((vva,vvb),Tup [va,vb])++class TyBasic a where+    rawType :: a -> Atom++data RawInt+type Rint = TyRaw RawInt++instance TyBasic RawInt where+    rawType _ = (toAtom "int")++gCase :: VVal a -> [Uniq Lam] -> GG+gCase (VVal v) ls = GG $ do+    ls <- sequence ls+    return $ Case v ls++gReturn :: VVal a -> GG+gReturn (VVal v) = GG $ return $ Return v++app2 :: Atom -> VVal a -> VVal b -> GG+app2 n (VVal a) (VVal b) = GG $ return (App n [a,b])++lLam :: Val -> Uniq Exp -> Uniq Lam+lLam v ue = do+    e <- ue+    return $ v :-> e++fact :: (Rint,Rint) -> GG+fact (n,r) = gCase n [unLam $ \ (x :: Rint) -> primMinus n 1 .>>= \ n' -> primTimes n r .>>= \r' -> app (toAtom "fact") [n',r'], lLam 1 (gReturn r) ]++embedTest = do+    putDoc $ prettyFun (toAtom "fact",execUniq1 $ unLam fact)
+ src/Grin/EvalInline.hs view
@@ -0,0 +1,162 @@+module Grin.EvalInline(createEvalApply) where++import Control.Monad.Identity+import Data.List hiding(union)+import qualified Data.Set as Set++import GenUtil+import Grin.Grin+import Grin.Noodle+import StringTable.Atom+import Support.CanType(getType)+import Support.FreeVars(freeVars)+import Util.Once+import Util.SetLike+import Util.UniqueMonad()++{-+data UpdateType =+    NoUpdate                  -- ^ no update is performed+    | TrailingUpdate          -- ^ an update is placed after the whole evaluation+    | HoistedUpdate Val+    | SwitchingUpdate [Atom]++mapExp f (b :-> e) = b :-> f e++-- create an eval suitable for inlining.+createEval :: UpdateType -> TyEnv -> [Tag] -> Lam+createEval shared  te ts'+    | null cs = p1 :-> Error "Empty Eval" TyNode+    | all tagIsWHNF [ t | t <- ts , tagIsTag t] = p1 :-> Fetch p1+    | NoUpdate <- shared, [t] <- ts = p1 :-> Fetch p1 :>>= f t+    | TrailingUpdate <- shared, [ot] <- ofts = p1 :->+        Fetch p1 :>>= n2 :->+        Case n2 (mapExp (:>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3) (f ot):map f whnfts)+    | TrailingUpdate <- shared = p1 :->+        Fetch p1 :>>= n2 :->+        Case n2 cs :>>= n3 :->+        Update p1 n3 :>>= unit :->+        Return n3+    | HoistedUpdate (NodeC t [v]) <- shared = p1 :->+        Fetch p1 :>>= n2 :->+        Case n2 cs :>>= v :->+        Return (NodeC t [v])+    | HoistedUpdate (NodeC t vs) <- shared = p1 :->+        Fetch p1 :>>= n2 :->+        Case n2 cs :>>= Tup vs :->+        Return (NodeC t vs)+    | NoUpdate <- shared = p1 :->+        Fetch p1 :>>= n2 :->+        Case n2 cs+    | SwitchingUpdate sts <- shared, [ot] <- ofts = p1 :->+        Fetch p1 :>>= n2 :->+        Case n2 (mapExp (:>>= sup p1 sts) (f ot):map f whnfts)+    | SwitchingUpdate sts <- shared = let+            lf = createEval NoUpdate te ts+--            cu t | tagIsTag t && tagIsWHNF t = return ans where+--                (ts,_) = runIdentity $ findArgsType te t+--                vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]+--                ans = NodeC t vs :-> Update p1 (NodeC t vs)+--            cu t = error $ "not updatable:" ++ show t+        in (p1 :-> (Return p1 :>>= lf) :>>= sup p1 sts) --  n3 :-> Case n3 (concatMap cu sts) :>>= unit :-> Return n3)+    where+    ts = sortUnder toPackedString ts'+    sup p sts = let+            cu t | tagIsTag t && tagIsWHNF t = return ans where+                (ts,_) = runIdentity $ findArgsType te t+                vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]+                ans = NodeC t vs :-> Update p1 (NodeC t vs)+            cu t = error $ "not updatable:" ++ show t+        in (n3 :-> Case n3 (concatMap cu sts) :>>= unit :-> Return n3)+    cs = [f t | t <- ts, tagIsTag t, isGood t ]+    isGood t | tagIsWHNF t, HoistedUpdate (NodeC t' _) <- shared, t /= t' = False+    isGood _ = True+    (whnfts,ofts) = partition tagIsWHNF (filter tagIsTag ts)+    g t vs+        | tagIsWHNF t, HoistedUpdate (NodeC t' [v]) <- shared  = case vs of+            [x] -> Return x+            _ -> error "createEval: bad thing"+        | tagIsWHNF t, HoistedUpdate (NodeC t' vars) <- shared  = Return (Tup vs)+        | tagIsWHNF t = Return (NodeC t vs)+        | 'F':fn <- fromAtom t  = ap ('f':fn) vs+        | 'B':fn <- fromAtom t  = ap ('b':fn) vs+        | otherwise = Error ("Bad Tag: " ++ fromAtom t) TyNode+    f t = (NodeC t vs :-> g t vs ) where+        (ts,_) = runIdentity $ findArgsType te t+        vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]+    ap n vs+    --    | shared =  App (toAtom $ n) vs :>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3+        | HoistedUpdate udp@(NodeC t []) <- shared = App fname vs ty :>>= n3 :-> Update p1 udp+        | HoistedUpdate udp@(NodeC t [v]) <- shared = App fname vs ty :>>= n3 :-> Return n3 :>>= udp :-> (Update p1 udp :>>= unit :-> Return v)+        | HoistedUpdate udp@(NodeC t vars) <- shared = App fname vs ty :>>= n3 :-> (Return n3 :>>= udp :-> (Update p1 udp) :>>= unit :-> Return (Tup vars))+        | otherwise = App fname vs ty+     where+        fname = toAtom n+        Just (_,ty) = findArgsType te fname+ -}+createApply :: Ty -> [Ty] -> TyEnv -> [Tag] -> Lam+createApply argType retType te ts'+    | null cs && argType == TyUnit = [n1] :-> Error ("Empty Apply:" ++ show ts)  retType+    | null cs = [n1,a2] :-> Error ("Empty Apply:" ++ show ts)  retType+    | argType == TyUnit = [n1] :-> Case n1 cs+    | otherwise = [n1,a2] :-> Case n1 cs+    where+    ts = sortBy atomCompare ts'+    a2 = Var v2 argType+    cs = [ f t | t <- ts, tagGood t]+    tagGood t | Just TyTy { tyThunk = TyPApp mt w } <- findTyTy te t =+         (Just argType == mt || (argType == TyUnit && Nothing == mt)) && (fmap snd $ findArgsType te w) == Just retType+    tagGood _ = False+--    tagGood t | Just (n,fn) <- tagUnfunction t, n > 0 = let+--        ptag = argType == ts !! (length ts - n)+--        rtag = retType == TyNode || (n == 1 && rt == retType)+--        (ts,rt) = runIdentity $ findArgsType te fn+--        in rtag && ptag+    f t = ([NodeC t vs] :-> g ) where+        (ts,_) = runIdentity $ findArgsType te t+        vs = [ Var v ty |  v <- [v3 .. ] | ty <- ts]+        Just (n,fn) = tagUnfunction t+        a2s = if argType == TyUnit then [] else [a2]+        g | n == 1 =  App fn (vs ++ a2s) ty+          | n > 1 = dstore (NodeC (partialTag fn (n - 1)) (vs ++ a2s))+          | otherwise = error "createApply"+         where+            Just (_,ty) = findArgsType te fn++dstore x = BaseOp (StoreNode True) [x]++{-# NOINLINE createEvalApply #-}+createEvalApply :: Grin -> IO Grin+createEvalApply grin = do+    let --eval = (funcEval,Tup [earg] :-> ebody) where+        --    earg :-> ebody  =  createEval TrailingUpdate (grinTypeEnv grin) tags+        tags = Set.toList $ ftags `Set.union` plads+        ftags = freeVars (map (lamExp . snd) $ grinFuncs grin)+        plads = Set.fromList $ concatMap mplad (Set.toList ftags)+        mplad t | Just (n,tag) <- tagUnfunction t, n > 1 = t:mplad (partialTag tag (n - 1))+        mplad t = [t]+    appMap <- newOnceMap+    let f (ls :-> exp) = do+            exp' <- g exp+            return $ ls :-> exp'+        g (BaseOp (Apply ty) [fun]) = do+            fn' <- runOnceMap appMap (TyUnit,ty) $ do+                u <- newUniq+                return (toAtom $ "bapply_" ++ show u)+            return (App fn' [fun] ty)+        g (BaseOp (Apply ty) [fun,arg]) = do+            fn' <- runOnceMap appMap (getType arg,ty) $ do+                u <- newUniq+                return (toAtom $ "bapply_" ++ show u)+            return (App fn' [fun,arg] ty)+        g x = mapExpExp g x+    funcs <- mapMsnd f (grinFuncs grin)+    as <- onceMapToList appMap+    let (apps,ntyenv) = unzip $ map cf as+        cf ((targ,tret),name) | targ == TyUnit = ((name,appBody),(name,tyTy { tySlots = [TyNode],tyReturn = tret })) where+            appBody = createApply targ tret (grinTypeEnv grin) tags+        cf ((targ,tret),name) = ((name,appBody),(name,tyTy { tySlots = [TyNode,targ],tyReturn = tret })) where+            appBody = createApply targ tret (grinTypeEnv grin) tags+        TyEnv tyEnv = grinTypeEnv grin+        appTyEnv = fromList ntyenv+    return $ setGrinFunctions (apps ++ funcs) grin { grinTypeEnv = TyEnv (tyEnv `union` appTyEnv) }
+ src/Grin/FromE.hs view
@@ -0,0 +1,735 @@+{-# LANGUAGE OverloadedStrings #-}+module Grin.FromE(compile) where++import Control.Monad.Reader+import Data.Graph(stronglyConnComp, SCC(..))+import Data.IORef+import Data.Monoid(Monoid(..))+import Data.List+import Data.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set++import C.FFI hiding(Primitive)+import C.Prims+import Cmm.Op(ToCmmTy(..))+import Control.Monad.Identity+import DataConstructors+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import E.E+import E.Program+import E.TypeCheck+import E.Values+import GenUtil+import Grin.Grin+import Grin.Noodle+import Grin.Show+import Grin.Val+import Info.Types+import Name.Id+import Name.Name+import Name.Names+import Options+import Stats(mtick')+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Graph as G+import Util.Once+import Util.SetLike as SL+import Util.UniqueMonad()+import qualified Cmm.Op as Op+import qualified FlagDump as FD+import qualified Info.Info as Info+import qualified Stats++{- | Tags+ 'f' - normal function+ 'F' - postponed function+ 'P' - partial application of function+ 'C' - data constructor+ 'T' - type constructor+ 'Y' - partial application of type constructor (think, broken T)+ 'b' - built in funttion+ 'B' - postponed built in function (built in functions may not be partially applied)+ '@' - very special function or tag+-}++-------------------+-- Compile E -> Exp+-------------------++unboxedMap :: [(Name,Ty)]+unboxedMap = [+    (tc_State_,TyUnit),+    (tc_MutArray__,TyPtr tyINode),+    (tc_Bang_,tyDNode)+    ]++newtype C a = C (ReaderT LEnv IO a)+    deriving(Monad,MonadReader LEnv,UniqueProducer,Functor,MonadIO,Stats.MonadStats)++runC :: LEnv -> C a -> IO a+runC lenv (C x) = runReaderT x lenv++data LEnv = LEnv {+    evaledMap :: IdMap Val,+    lfuncMap  :: IdMap (Atom,Int,[Ty])+}++data CEnv = CEnv {+    scMap :: IdMap (Atom,[Ty],[Ty]),+    ccafMap :: IdMap Val,+    tyEnv :: IORef TyEnv,+    funcBaps :: IORef [(Atom,Lam)],+    errorOnce :: OnceMap ([Ty],String) Atom,+    dataTable :: DataTable,+    counter :: IORef Int+}++dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ fromAtom n <+> hsep (map show as) <+> "::" <+> show t <> f z <> g th|  (n,TyTy { tySlots = as, tyReturn = t, tySiblings = z, tyThunk = th}) <- toList tt] where+    f Nothing = mempty+    f (Just v) = text " " <> tshow v+    g TyNotThunk = mempty+    g x = text " " <> tshow x++tagArrow = convertName tc_Arrow++flattenScc xs = concatMap f xs where+    f (AcyclicSCC x) = [x]+    f (CyclicSCC xs) = xs++instance Op.ToCmmTy Name where+    toCmmTy n = do+        RawType <- return $ nameType n+        toCmmTy $ show n++instance Op.ToCmmTy E where+    toCmmTy (ELit LitCons { litName = tname, litArgs = [], litAliasFor = af, litType = eh  }) | eh == eHash = toCmmTy tname `mplus` (af >>= toCmmTy)+    toCmmTy _ = Nothing++scTag n+    | Just nm <- fromId (tvrIdent n) = toAtom ('f':show nm)+    | otherwise = toAtom ('f':show (tvrIdent n))+cafNum n = V $ - fromAtom (partialTag (scTag n) 0)++toEntry (n,as,e) = f (scTag n) where+        f x = (x,map (toType tyINode . tvrType )  as,toTypes TyNode (getType (e::E) :: E))++toType :: Ty -> E -> Ty+toType node = toty . followAliases mempty where+    toty (ELit LitCons { litName = n, litArgs = [], litType = ty }) |  ty == eHash, TypeConstructor <- nameType n, Just 0 <- fromUnboxedNameTuple n = TyUnit+    toty e | Just t <- toCmmTy e = TyPrim t+    toty e@(ELit LitCons { litName = n, litType = ty }) |  ty == eHash = case lookup n unboxedMap of+        Just x -> x+        Nothing -> error $ "Grin.FromE.toType: " ++ show e+    toty e |  sortKindLike e = tyDNode+    toty _ = node++toTypes :: Ty -> E -> [Ty]+toTypes node = toty . followAliases mempty where+    toty (ELit LitCons { litName = n, litArgs = es, litType = ty }) |  ty == eHash, TypeConstructor <- nameType n, Just _ <- fromUnboxedNameTuple n = keepIts $ map (toType tyINode) es+    toty e | Just t <- toCmmTy e = [TyPrim t]+    toty e@(ELit LitCons { litName = n, litType = ty }) |  ty == eHash = case lookup n unboxedMap of+        Just TyUnit -> []+        Just x -> [x]+        Nothing -> error $ "Grin.FromE.toType: " ++ show e+    toty e |  sortKindLike e = [tyDNode]+    toty _ = [node]++toTyTy (as,r) = tyTy { tySlots = as, tyReturn = r }++{-# NOINLINE compile #-}+compile :: Program -> IO Grin+compile prog@Program { progDataTable = dataTable } = do+    let entries = progEntryPoints prog+        mainEntry = progMainEntry prog+    tyEnv <- liftIO $ newIORef initTyEnv+    funcBaps <- liftIO $ newIORef []+    counter <- liftIO $ newIORef 100000  -- TODO real number+    let (cc,reqcc,rcafs) = constantCaf prog+        funcMain = "b_main" :: Atom+    wdump FD.Progress $ do+        putErrLn $ "Updatable CAFS:" <+> tshow (length rcafs)+        putErrLn $ "Constant CAFS: " <+> tshow (length cc)+        putErrLn $ "Recursive CAFS:" <+> tshow (length reqcc)+--        putErrLn $ "Found" <+> tshow (length cc) <+> "CAFs to convert to constants," <+> tshow (length reqcc) <+> "of which are recursive."+    when verbose $ do+        putErrLn "Recursive"+        putDocMLn putStr $ vcat [ pprint v  | v <- reqcc ]+        putErrLn "Constant"+        putDocMLn putStr $ vcat [ pprint v <+> pprint n <+> pprint e | (v,n,e) <- cc ]+        putErrLn "CAFS"+        putDocMLn putStr $ vcat [ pprint v <+> pprint n <+> pprint e | (v,n,e) <- rcafs ]+    errorOnce <- newOnceMap+    let doCompile = compile' cenv+        lenv = LEnv { evaledMap = mempty, lfuncMap = mempty }+        cenv = CEnv {+            funcBaps = funcBaps,+            tyEnv = tyEnv,+            scMap = scMap,+            counter = counter,+            dataTable = dataTable,+            errorOnce = errorOnce,+            ccafMap = fromList $ [(tvrIdent v,e) |(v,_,e) <- cc ]  ++ [ (tvrIdent v,Var vv TyINode) | (v,vv,_) <- rcafs]+            }+    ds <- runC lenv $ mapM doCompile [ c | c@(v,_,_) <- map combTriple $ progCombinators prog, v `notElem` [x | (x,_,_) <- cc]]+    wdump FD.Progress $ do+        os <- onceMapToList errorOnce+        mapM_ print os+    let tf a = a:tagToFunction a+    ds <- return $ flattenScc $ stronglyConnComp [ (a,x, concatMap tf (freeVars z)) | a@(x,(_ :-> z)) <- ds]++    -- FFI+    let tvrAtom t  = liftM convertName (fromId $ tvrIdent t)+    --let ef x = do n <- tvrAtom x+    --           return (n, [] :-> discardResult (App (scTag x) [] []))+    let ep x = do when verbose $ putStrLn ("EP FOR "++show x)+                  n <- tvrAtom x+                  case Info.lookup (tvrInfo x) of+                    Just l -> return [(n, l)]+                    Nothing -> return []+    -- efv <- mapM ef entries -- FIXME+    efv <- return []+    epv <- liftM concat $ mapM ep entries+    enames <- mapM tvrAtom entries++    TyEnv endTyEnv <- readIORef tyEnv+    -- FIXME correct types.+    let newTyEnv = TyEnv $ fromList (toList endTyEnv ++ [(funcMain, toTyTy ([],[]))] ++ [(en, toTyTy ([],[])) | en <- enames])+    wdump FD.Tags $ do+        dumpTyEnv newTyEnv+    fbaps <- readIORef funcBaps+    let cafs = [ (x,y) | (_,x,y) <- rcafs ]+        --initCafs = sequenceG_ [ BaseOp Overwrite [(Var v TyINode),node] | (v,node) <- cafs ]+        initCafs = Return []+        ds' = ds ++ fbaps+        --a @>> b = a :>>= ([] :-> b)+        --sequenceG_ [] = Return []+        --sequenceG_ (x:xs) = foldl (@>>) x xs+    let grin = setGrinFunctions theFuncs emptyGrin {+            grinEntryPoints = minsert funcMain (FfiExport "_amain" Safe CCall [] "void") $+                                fromList epv,+            grinPhase = PhaseInit,+            grinTypeEnv = newTyEnv,+            grinCafs = [ (x,node) | (x,node) <- cafs]+            }+        theFuncs = (funcMain ,[] :-> initCafs :>>= [] :->  discardResult (App (scTag mainEntry) [] [])) : efv ++ ds'+    return grin+    where+    DataTable dtMap = dataTable+    scMap = fromList [ (tvrIdent t,toEntry x) |  x@(t,_,_) <- map combTriple $ progCombinators prog]+    initTyEnv = mappend primTyEnv $ TyEnv $ fromList $ concat [ makePartials (a,b,c) | (_,(a,b,c)) <-  toList scMap] ++ concat [con x| x <- [cabsurd] ++ values dtMap, conType x /= eHash]+    Just cabsurd = getConstructor (nameConjured modAbsurd eStar) mempty+    con c | (EPi (TVr { tvrType = a }) b,_) <- fromLam $ conExpr c = return $ (tagArrow,toTyTy ([tyDNode, tyDNode],[TyNode]))+    con c | keepCon = return $ (n,TyTy { tyThunk = TyNotThunk, tySlots = keepIts as, tyReturn = [TyNode], tySiblings = fmap (map convertName) sibs}) where+        n | sortKindLike (conType c) = convertName (conName c)+          | otherwise = convertName (conName c)+        as = [ toType TyINode s |  s <- conSlots c]+        keepCon = isNothing (conVirtual c) || TypeConstructor == nameType (conName c)+        sibs = getSiblings dataTable (conName c)+    con _ = fail "not needed"++discardResult exp = exp :>>= map (Var v0) (getType exp) :-> Return []++shouldKeep :: E -> Bool+shouldKeep e = TyUnit /= toType TyNode e++class Keepable a where+    keepIt :: a -> Bool++--instance Keepable E where+--    keepIt = shouldKeep+instance Keepable Ty where+    keepIt t = t /= TyUnit+instance Keepable Val where+    keepIt t = getType t /= TyUnit++keepIts xs = filter keepIt xs++tySusp fn ts = (partialTag fn 0,(toTyTy (keepIts ts,[TyNode])) { tyThunk = TySusp fn })++makePartials (fn,ts,rt) | 'f':_ <- show fn = (fn,toTyTy (keepIts ts,rt)):f undefined 0 (reverse ts) where+    f _ 0 ts = tySusp fn (reverse ts):f fn 1 ts+    f nfn n (t:ts) = (mfn,(toTyTy (reverse $ keepIts ts,[TyNode])) { tyThunk = TyPApp (if keepIt t then Just t else Nothing) nfn }):f mfn (n + 1) ts  where+        mfn = partialTag fn n+    f _ _ [] = []+--    ans = (fn,toTyTy (keepIts ts,rt)):[(partialTag fn i,toTyTy (keepIts $ reverse $ drop i $ reverse ts ,TyNode)) |  i <- [0.. length ts] ]+makePartials x = error "makePartials"++primTyEnv = TyEnv . fmap toTyTy $ fromList $ [+    (tagArrow,([tyDNode, tyDNode],[TyNode])),+    (tagHole, ([],[TyNode]))+    ]++-- | constant CAF analysis+-- In grin, partial applications are constant data, rather than functions. Since+-- many cafs consist of constant applications, we preprocess them into values+-- beforehand. This also catches recursive constant toplevel bindings.+--+-- takes a program and returns (cafs which are actually constants,which are recursive,rest of cafs)++constantCaf :: Program -> ([(TVr,Var,Val)],[Var],[(TVr,Var,Val)])+constantCaf Program { progDataTable = dataTable, progCombinators = combs } = ans where+    ds = map combTriple combs+    -- All CAFS+    ecafs = [ (v,e) | (v,[],e) <- ds ]+    -- just CAFS that can be converted to constants need dependency analysis+    (lbs',cafs) = G.findLoopBreakers (const 0) (const True) $ G.newGraph (filter (canidate . snd) ecafs) (tvrIdent . fst) (freeVars . snd)+    lbs = Set.fromList $ fsts lbs'+    canidate (ELit _) = True+    canidate (EPi _ _) = True+    canidate e | (EVar x,as) <- fromAp e, Just vs <- mlookup x res, vs > length as = True+    canidate _ = False+    ans = ([ (v,cafNum v,conv e) | (v,e) <- cafs ],[ cafNum v | (v,_) <- cafs, v `Set.member` lbs ], [(v,cafNum v, NodeC (partialTag n 0) []) | (v,e) <- ecafs, not (canidate e), let n = scTag v ])+    res = Map.fromList [ (v,length vs) | (v,vs,_) <- ds]+    coMap = Map.fromList [  (v,ce)| (v,_,ce) <- fst3 ans]+    conv :: E -> Val+    conv e | Just [v] <- literal e = v+    conv (ELit lc@LitCons { litName = n, litArgs = es }) | Just nn <- getName lc = (Const (NodeC nn (keepIts $ map conv es)))+    conv (EPi (TVr { tvrIdent = z, tvrType =  a}) b) | isEmptyId z =  Const $ NodeC tagArrow [conv a,conv b]+    conv (EVar v) | v `Set.member` lbs = Var (cafNum v) TyINode+    conv e | (EVar x,as) <- fromAp e, Just vs <- mlookup x res, vs > length as = Const (NodeC (partialTag (scTag x) (vs - length as)) (keepIts $ map conv as))+    conv (EVar v) | Just ce <- mlookup v coMap = ce+    conv e@(EVar v) | isLifted e = Var (cafNum v) tyINode+                    | otherwise = Var (cafNum v) tyDNode+    conv x = error $ "conv: " ++ show x+    getName = getName' dataTable++    fst3 (x,_,_) = x++getName' :: (Show a,Monad m) => DataTable -> Lit a E -> m Atom+getName' dataTable v@LitCons { litName = n, litArgs = es }+    | Just _ <- fromUnboxedNameTuple n = fail $ "unboxed tuples don't have names silly"+    | isDataAlias (conChildren cons) = error $ "Alias still exists: " ++ show v+    | length es == nargs  = do+        return cn+    | nameType n == TypeConstructor && length es < nargs = do+        return ((partialTag cn (nargs - length es)))+    | otherwise = error $ "Strange name: " ++ show v ++ show nargs ++ show cons+    where+    cn = convertName n+    cons = runIdentity $ getConstructor n dataTable+    nargs = length (conSlots cons)+getName' _ _ = error "FromE.getName': bad."++isDataAlias x = case x of+    DataAlias {} -> True+    _ -> False++instance ToVal TVr where+    toVal TVr { tvrType = ty, tvrIdent = num } = case toType TyINode ty of+--        TyTup [] -> Tup []+        ty -> Var (V $ idToInt num) ty++doApply x y ty | not (keepIt y) = BaseOp (Apply ty) [x]+doApply x y ty = BaseOp (Apply ty) [x,y]++istore (NodeC t ts) | tagIsWHNF t = dstore (NodeC t ts) :>>= [Var v1 TyNode] :-> demote (Var v1 TyNode)+istore n = BaseOp (StoreNode False) [n]+dstore n = BaseOp (StoreNode True) [n]+demote v = BaseOp Demote [v]++evalVar :: [Ty] -> TVr -> C Exp+evalVar fty tvr  = do+    let v = toVal tvr+    if getType v == tyDNode then return $ Return [v] else do+    em <- asks evaledMap+    case mlookup (tvrIdent tvr) em of+        Just v -> do+            mtick' "Grin.FromE.strict-evaled"+            return (Return [v])+--        Nothing | not isFGrin, Just CaseDefault <- Info.lookup (tvrInfo tvr) -> do+--            mtick "Grin.FromE.strict-casedefault"+--            return (Fetch (toVal tvr))+        Nothing | getProperty prop_WHNF tvr -> do+            mtick' "Grin.FromE.strict-propevaled"+            return (BaseOp Promote [toVal tvr])+        Nothing -> return $ gEval (toVal tvr)++compile' ::  CEnv -> (TVr,[TVr],E) -> C (Atom,Lam)+compile' cenv (tvr,as,e) = ans where+    ans = do+        when (getProperty prop_WRAPPER tvr) $+            liftIO $ putErrLn $ "WARNING: Wrapper still exists at grin transformation time: " ++ show tvr+        --putStrLn $ "Compiling: " ++ show nn+        x <- cr e+        let (nn,_,_) = fromJust $ mlookup (tvrIdent tvr) (scMap cenv)+        return (nn,((keepIts $ map toVal as) :-> x))+    funcName = maybe (show $ tvrIdent tvr) show (fromId (tvrIdent tvr))+    cc, ce, cr :: E -> C Exp+    cr x = ce x++    -- | ce evaluates something in strict context returning the evaluated result of its argument.+    ce (ELetRec ds e) = doLet ds (ce e)+    ce (EError s e) = return (Error s (toTypes TyNode e))+    ce (EVar tvr) | isUnboxed (getType tvr) = do+        return (Return $ keepIts [toVal tvr])+    ce (EVar tvr) | not $ isLifted (EVar tvr)  = do+        mtick' "Grin.FromE.strict-unlifted"+        return (Return $ keepIts [toVal tvr])+        --return (Fetch (toVal tvr))+    ce e | (EVar tvr,as) <- fromAp e = do+        as <- return $ args as+        lfunc <- asks lfuncMap+        let fty = toTypes TyNode (getType e)+        case mlookup (tvrIdent tvr) (ccafMap cenv) of+            Just (Const c) -> app fty (Return [c]) as+            Just x@Var {} -> app fty (gEval x) as+            Nothing | Just (v,n,rt) <- mlookup (tvrIdent tvr) lfunc -> do+                    let (x,y) = splitAt n as+                    app fty (App v (keepIts x) rt) y+            Nothing -> case mlookup (tvrIdent tvr) (scMap cenv) of+                Just (v,as',es)+                    | length as >= length as' -> do+                        let (x,y) = splitAt (length as') as+                        app fty (App v (keepIts x) es) y+                    | otherwise -> do+                        let pt = partialTag v (length as' - length as)+                        return $ dstore (NodeC pt (keepIts as))+                Nothing | not (isLifted $ EVar tvr) -> do+                    mtick' "Grin.FromE.app-unlifted"+                    app fty (Return [toVal tvr]) as+                Nothing -> do+                    case as of+                        [] -> evalVar fty tvr+                        _ -> do+                            ee <- evalVar [TyNode] tvr+                            app fty ee as+            _ -> error "FromE.ce: bad."+    ce e | Just z <- literal e = return (Return z)+    ce e | Just (Const z) <- constant e = return (Return $ keepIts [z])+    ce e | Just z <- constant e = return (gEval z)+    ce e | Just [z@NodeC {}] <- con e = return (dstore z)+    ce e | Just z <- con e = return (Return z)++    ce (EPrim ap@(PrimPrim prim) as _) = f prim as where+        f "touch_" xs = do+            return $ BaseOp GcTouch (args $ init xs)+        -- artificial dependencies+        f "newWorld__" [_] = do+            return $ Return []+        f "dependingOn" [e,_] = ce e+        -- arrays+        f "newArray__" [v,def,_] = do+            let [v',def'] = args [v,def]+            return $ Alloc { expValue = def', expCount = v', expRegion = region_heap, expInfo = mempty }+        f "newBlankArray__" [v,_] = do+            let [v'] = args [v]+            return $ Alloc { expValue = ValUnknown TyINode, expCount = v', expRegion = region_heap, expInfo = mempty }+        f "readArray__" [r,o,_] = do+            let [r',o'] = args [r,o]+            --return $ Fetch (Index r' o')+            return $ BaseOp PeekVal [Index r' o']+        f "indexArray__" [r,o] = do+            let [r',o'] = args [r,o]+            return $ BaseOp PeekVal [Index r' o']+        f "writeArray__" [r,o,v,_] = do+            let [r',o',v'] = args [r,o,v]+            return $ BaseOp PokeVal [(Index r' o'),v']+        -- rts+        f "toBang_" (args -> [x]) = do+            return $ if getType x == tyDNode then Return [x] else gEval x+        f "fromBang_" [x] = do+            return $ Return (args [x]) -- (BaseOp Demote $ args [x])+        f "mallocHeapWords" [w,_] = do+            let [c] = args [w]+            v <- newPrimVar (TyPtr (TyPrim Op.bits_ptr))+            return $ Alloc { expValue = ValUnknown (TyPrim Op.bits_ptr),+                expCount = c, expRegion = region_atomic_heap, expInfo = mempty } :>>= [v] :-> BaseOp (Coerce tyDNode) [v]+        f p xs = fail $ "Grin.FromE - Unknown primitive: " ++ show (p,xs)++    -- other primitives+    ce (EPrim ap xs ty) = do+        --let prim = ap+        let xs' = keepIts $ args xs+            ty' = toTypes TyNode ty++        case ap of+            PrimTypeInfo {} -> return $ Prim ap xs' ty'+            Func {} -> return $ Prim ap xs' ty'+            IFunc {} -> return $ Prim ap xs' ty'+            --Func True fn as "void" -> return $ Prim ap xs' ty'+            --Func True fn as r      -> return $ Prim ap xs' ty'+            --Func False _ as r | Just _ <- toCmmTy ty ->  do+            --    return $ Prim ap xs' ty'+            --IFunc True _ _ ->+            --    return $ Prim ap xs' ty'+            --IFunc False _ _ | Just _ <- toCmmTy ty ->+            --    return $ Prim ap xs' ty'+            Peek pt' | [addr] <- xs -> do+                return $ Prim ap (args [addr]) ty'+            Peek pt' -> do+                let [_,addr] = xs+                return $ Prim ap (args [addr]) ty'+            Poke pt' ->  do+                let [_,addr,val] = xs+                return $  Prim ap (args [addr,val]) []+            Op (Op.BinOp _ a1 a2) rt -> do+                return $ Prim ap (args xs) ty'+            Op (Op.UnOp _ a1) rt -> do+                return $ Prim ap (args xs) ty'+            Op (Op.ConvOp _ a1) rt -> do+                return $ Prim ap (args xs) ty'+            other -> fail $ "ce unknown primitive: " ++ show other++    -- case statements+    ce ECase { eCaseScrutinee = e, eCaseAlts = [Alt LitCons { litName = n, litArgs = xs } wh] } | Just _ <- fromUnboxedNameTuple n, DataConstructor <- nameType n  = do+        e <- ce e+        wh <- ce wh+        return $ e :>>= (keepIts $ map toVal xs) :-> wh+    ce ECase { eCaseScrutinee = e, eCaseAlts = [], eCaseDefault = (Just r)} | not (shouldKeep (getType e)) = do+        e <- ce e+        r <- ce r+        return $ e :>>= [] :-> r+    ce ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } |  Just ty <- toCmmTy (getType e :: E) = do+            v <- if tvrIdent b == emptyId then newPrimVar $ TyPrim ty else return $ toVal b+            e <- ce e+            as' <- mapM cp'' as+            def <- createDef d (return (toVal b))+            return $+                e :>>= [v] :-> Case v (as' ++ def)+    ce ECase { eCaseScrutinee = scrut, eCaseBind = b, eCaseAlts = as, eCaseDefault = d }  = do+        v <- newNodeVar+        e <- ce scrut+        case (b,scrut) of+            (TVr { tvrIdent = z },EVar etvr) | isEmptyId z -> localEvaled [etvr] v $ do+                    as <- mapM cp as+                    def <- createDef d newNodeVar+                    return $ e :>>= [v] :-> Case v (as ++ def)+--            (_,EVar etvr) -> localEvaled [etvr,b] v $ do+--                    as <- mapM cp as+--                    def <- createDef d newNodeVar+--                    return $ e :>>= [v] :-> Return [toVal etvr] :>>= [toVal b] :-> Case v (as ++ def)+            (TVr { tvrIdent = z },_) | isEmptyId z -> do+                as <- mapM cp as+                def <- createDef d newNodeVar+                return $ e :>>= [v] :-> Case v (as ++ def)+            (_,_) | isLifted scrut -> localEvaled [b] v $ do+                    as <- mapM cp as+                    def <- createDef d newNodeVar+                    return $ e :>>= [v] :-> demote v :>>= [toVal b] :-> Case v (as ++ def)+            (_,_) | otherwise -> do+                    as <- mapM cp as+                    def <- createDef d newNodeVar+                    return $ e :>>= [toVal b] :-> Case (toVal b) (as ++ def)+    ce e = error $ render (text "Grin.FromE.compile'.ce in function:" <+> pprint funcName+                           <$> text "can't grok expression:" <+> pprint e)++    localEvaled vs v action = local (\lenv -> lenv { evaledMap = nm `mappend` evaledMap lenv }) action where+        nm = fromList [ (tvrIdent x, v) | x <- vs, tvrIdent x /= emptyId ]++    localFuncs vs action = local (\lenv -> lenv { lfuncMap = fromList vs `mappend` lfuncMap lenv }) action++    createDef Nothing _ = return []+    createDef (Just e) nnv = do+        nv <- nnv+        x <- ce e+        return [[nv] :-> x]+    cp (Alt lc@LitCons { litName = n, litArgs = es } e) = do+        x <- ce e+        nn <- getName lc+        return ([NodeC nn (keepIts $ map toVal es)] :-> x)+    cp x = error $ "cp: " ++ show (funcName,x)+    cp'' (Alt (LitInt i t) e) | Just ty <- toCmmTy t = do+        x <- ce e+        return ([Lit i $ TyPrim ty] :-> x)+    cp'' _ = error "FromE.cp'': bad."++    getName x = getName' (dataTable cenv) x++    app :: [Ty] -> Exp -> [Val] -> C Exp+    app _ e [] = return e+    app ty e [a] | not (keepIt a) = do+        v <- newNodeVar+        return (e :>>= [v] :-> BaseOp (Apply ty) [v])+    app ty e [a] = do+        v <- newNodeVar+        return (e :>>= [v] :-> doApply v a ty)+    app ty e (a:as) | not (keepIt a) = do+        v <- newNodeVar+        app ty (e :>>= [v] :-> BaseOp (Apply [TyNode]) [v]) as+    app ty e (a:as) = do+        v <- newNodeVar+        app ty (e :>>= [v] :-> doApply v a [TyNode]) as++    app' e [] = return $ Return [e]+    app' e as = do+        mtick' "Grin.FromE.lazy-app-bap"+        V vn <- newVar+        let t  = toAtom $ "Bap_" ++ show (length as) ++ "_" ++ funcName ++ "_" ++ show vn+            tl = toAtom $ "bap_" ++ show (length as) ++ "_" ++  funcName ++ "_" ++ show vn+            targs = [Var v ty | v <- [v1..] | ty <- (TyINode:map getType as)]+            s = istore (NodeC t (keepIts $ e:as))+        d <- app [TyNode] (gEval p1) (tail targs)+        liftIO $ addNewFunction cenv (tl,(keepIts targs) :-> d)+        return s+    addNewFunction cenv tl@(n,args :-> body) = do+        liftIO $ modifyIORef (funcBaps cenv) (tl:)+        let addt (TyEnv mp) =  TyEnv $ minsert sfn sft (minsert n (toTyTy (args',getType body)) mp)+            (sfn,sft) = tySusp n args'+            args' = map getType args+        liftIO $ modifyIORef (tyEnv cenv) addt++    -- | cc evaluates something in lazy context, returning a pointer to a node which when evaluated will produce the strict result.+    -- it is an invarient that evaling (cc e) produces the same value as (ce e)+    cc (EPrim don [e,_] _) | don == p_dependingOn  = cc e+    cc (EPrim (PrimPrim "fromBang_") (args -> [e]) _) = return $ if getType e == tyDNode then demote e else Return [e] -- $ demote e+--        e <- ce e+--        return $ e :>>= [v] :-> demote v+    cc e | Just _ <- literal e = error "unboxed literal in lazy context"+    cc e | Just z <- constant e = return (Return $ keepIts [z])+    cc e | Just [z] <- con e = return $ bool (isLifted e) istore dstore z -- BaseOp (StoreNode (not $ isLifted e)) [z] -- if isLifted e then Store z else Return [z]+    cc (EError s e) = do+        let ty = toTypes TyNode e+        a <- liftIO $ runOnceMap (errorOnce cenv) (ty,s) $ do+            u <- newUniq+            let t  = toAtom $ "Berr_" ++ show u+                tl = toAtom $ "berr_" ++ show u+            addNewFunction cenv (tl,[] :-> Error s ty)+            return t+        return $ Return [Const (NodeC a [])]+    cc (ELetRec ds e) = doLet ds (cc e)+    cc e | (EVar v,as@(_:_)) <- fromAp e = do+        as <- return $ args as+        case mlookup (tvrIdent v) (scMap cenv) of+            Just (_,[],_) | Just x <- constant (EVar v) -> app' x as+            Just (v,as',es)+                | length as > length as' -> do+                    let (x,y) = splitAt (length as') as+                    let s = istore (NodeC (partialTag v 0) (keepIts x))+                    nv <- newNodePtrVar+                    z <- app' nv y+                    return $ s :>>= [nv] :-> z+--                | length as < length as', all valIsConstant as -> do+--                    let pt = partialTag v (length as' - length as)+--                    mtick "Grin.FromE.partial-constant"+--                    return $ Return (Const (NodeC pt as))+                | length as < length as' -> do+                    let pt = partialTag v (length as' - length as)+                    as <- return $ keepIts as+                    return $ if all valIsConstant as+                      then Return [Const (NodeC pt as)]+                      else istore (NodeC pt as)+                | otherwise -> do -- length as == length as'+                    return $ istore (NodeC (tagFlipFunction v) (keepIts as))+            Nothing -> app' (toVal v) as+    cc (EVar v) = do+        return $ Return [toVal v]+    cc e = return $ error ("cc: " ++ show e)++    doLet ds e = f (decomposeDs ds) e where+        f [] x = x+        f (Left te@(_,ELam {}):ds) x = f (Right [te]:ds) x+        f (Left (t,e):ds) x | not (isLifted (EVar t)) = do+            mtick' "Grin.FromE.let-unlifted"+            e <- ce e+            z <- newNodeVar+            v <- localEvaled [t] z $ f ds x+            return $ (e :>>= [z] :-> Return [z]) :>>= [toVal t] :-> v+        f (Left (t,e):ds) x = do+            e <- cc e+            v <- f ds x+            return $ e :>>= [toVal t] :-> v+        f (Right bs:ds) x | any (isELam . snd) bs = do+            let g (t,e@(~ELam {})) = do+                    let (a,as) = fromLam e+                        (nn,_,_) = toEntry (t,[],getType t)+                    x <- ce a+                    return $ [createFuncDef True nn ((keepIts $ map toVal as) :-> x)]+                g' (t,e@(~ELam {})) =+                    let (a,as) = fromLam e+                        (nn,_,_) = toEntry (t,[],getType t)+                    in (tvrIdent t,(nn,length as,toTypes TyNode (getType a)))+            localFuncs (map g' bs) $ do+                v <- f ds x+                defs <- mapM g bs+                return $ grinLet (concat defs) v++        f (Right bs:ds) x = do+            let u [] ss dus = return (\y -> ss (dus y))+                u ((tvr,e):rs) ss dus = do+                    v <- newNodePtrVar+                    v' <- newNodeVar+                    e <- cc e+                    let (du,t,ts) = doUpdate (toVal tvr) e+                    u rs (\y -> istore (NodeC t (map ValUnknown ts)) :>>= [toVal tvr] :-> ss y) (\y -> du :>>= [] :-> dus y)+            rr <- u bs id id+            v <- f ds x+            return (rr v)++    -- This avoids a blind update on recursive thunks+    --doUpdate vr (Store n@(NodeC t ts)) = (BaseOp Overwrite [vr,n],t,map getType ts)+    doUpdate vr (BaseOp StoreNode {} [n@(NodeC t ts)]) = (BaseOp Overwrite [vr,n],t,map getType ts)+    doUpdate vr (BaseOp StoreNode {} [n@(NodeC t ts)] :>>= [p] :-> BaseOp Demote [p']) | p == p' = (BaseOp Overwrite [vr,n],t,map getType ts)+    doUpdate vr (x :>>= v :-> e) = let (du,t,ts) = doUpdate vr e in (x :>>= v :-> du,t,ts)+    doUpdate vr x = error $ "doUpdate: " ++ show x+    args es = map f es where+        f x | Just [] <- literal x = Unit+        f x | Just [z] <- literal x = z+        f x | Just z <- constant x =  z+        f (EVar tvr) = toVal tvr+        f x = error $ "invalid argument: " ++ show x++    -- | Takes an E and returns something constant which is either a pointer to+    -- a constant heap location only pointing to global values or constants.+    -- this includes a CAF which may be evaluated, a literal, a saturated+    -- application of constant values to a supercombinator, or a constructor+    -- containing constant values. constant is sort of a misnomer here when+    -- runtime behavior is considered, it means a compile time constant, the+    -- CAFs may be updated with evaluated values.++    constant :: Monad m =>  E -> m Val+    constant (EVar tvr) | Just c <- mlookup (tvrIdent tvr) (ccafMap cenv) = return c+                        | Just (v,as,_) <- mlookup (tvrIdent tvr) (scMap cenv)+                         , t <- partialTag v (length as), tagIsWHNF t = if isLifted (EVar tvr) then return $ Const $ NodeC t [] else return (NodeC t [])+    --                        False -> return $ Var (V $ - fromAtom t) (TyPtr TyNode)+    constant e | Just [l] <- literal e = return l+    constant e@(ELit lc@LitCons { litName = n, litArgs = es }) | Just es <- mapM constant es, Just nn <- getName lc = if isLifted e+        then return $ Const (NodeC nn (keepIts es))+        else return (NodeC nn (keepIts es))+    constant (EPi (TVr { tvrIdent = z, tvrType = a}) b) | isEmptyId z, Just a <- constant a, Just b <- constant b = return $ NodeC tagArrow [a,b]+    constant _ = fail "not a constant term"++    -- | convert a constructor into a Val, arguments may depend on local vars.+    con :: Monad m => E -> m [Val]+    con (EPi (TVr {tvrIdent =  z, tvrType = x}) y) | isEmptyId z = do+        return $  [NodeC tagArrow (args [x,y])]+    con v@(ELit LitCons { litName = n, litArgs = es })+        | isDataAlias (conChildren cons) = error $ "Alias still exists: " ++ show v+        | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = do+            return ((keepIts $ args es))+        | length es == nargs  = do+            return [NodeC cn (keepIts $ args es)]+        | nameType n == TypeConstructor && length es < nargs = do+            return [NodeC (partialTag cn (nargs - length es)) $ keepIts (args es)]+        where+        cn = convertName n+        cons = runIdentity $ getConstructor n (dataTable cenv)+        nargs = length (conSlots cons)++    con _ = fail "not constructor"++    --scInfo tvr | Just n <- mlookup (tvrIdent tvr) (scMap cenv) = return n+    --scInfo tvr = fail $ "not a supercombinator:" <+> show tvr+    newNodeVar =  fmap (\x -> Var x TyNode) newVar+    newPrimVar ty =  fmap (\x -> Var x ty) newVar+    newNodePtrVar =  fmap (\x -> Var x TyINode) newVar+    newVar = do+        i <- liftIO $ readIORef (counter cenv)+        liftIO $ (writeIORef (counter cenv) $! (i + 2))+        return $! V i++-- | converts an unboxed literal+literal :: Monad m =>  E -> m [Val]+literal (ELit LitCons { litName = n, litArgs = xs })  |  Just xs <- mapM literal xs, Just _ <- fromUnboxedNameTuple n = return (keepIts $ concat xs)+literal (ELit (LitInt i ty)) | Just ptype <- toCmmTy ty = return $ [Lit i (TyPrim ptype)]+literal (ELit (LitInt i (ELit (LitCons { litArgs = [], litAliasFor = Just af }))))  = literal $ ELit (LitInt i af)+literal (EPrim prim xs ty) | Just ptype <- toCmmTy ty, primIsConstant prim = do+    xs <- mapM literal xs+    return $ [ValPrim prim (concat xs) (TyPrim ptype)]+literal _ = fail "not a literal term"++bool b x y = if b then x else y
+ src/Grin/Grin.hs view
@@ -0,0 +1,733 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++module Grin.Grin(+    Callable(..),+    Exp(..),+    FuncDef(..),+    FuncProps(..),+    Grin(..),+    TyThunk(..),+    Lam(..),+    Phase(..),+    BaseOp(..),+    Tag,+    updateFuncDefProps,+    Ty(..),+    TyEnv(..),+    TyTy(..),+    tyTy,+    Val(..),+    Var(..),+    extendTyEnv,+    createFuncDef,+    setGrinFunctions,+    grinFuncs,+    emptyGrin,+    tyINode,+    tyDNode,+    findArgs,+    findArgsType,+    findTyTy,+    gEval,+    grinEntryPointNames,+    isHole,+    isValUnknown,+    isVar,+    n0,n1,n2,n3,+    p0,p1,p2,p3,+    partialTag,+    phaseEvalInlined,+    properHole,+    tagFlipFunction,+    tagHole,+    tagInfo,+    TagInfo(..),+    tagIsFunction,+    tagIsPartialAp,+    tagIsSuspFunction,+    tagIsTag,+    tagIsWHNF,+    tagToFunction,+    tagUnfunction,+    v0,v1,v2,v3,lamExp,lamBind,+    valIsNF+    ) where++import Control.Monad.Identity+import Data.Char+import Data.Monoid(Monoid(..))+import Data.List(isPrefixOf)+import qualified Data.Set as Set++import C.FFI+import C.Prims+import Cmm.Number+import Doc.DocLike+import Name.VConsts+import Options+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.GMap+import Util.Gen+import Util.HasSize+import Util.Perhaps+import Util.SetLike+import qualified Cmm.Op as Op+import qualified Info.Info as Info+import qualified Stats++-- Extremely simple first order monadic code with basic type system.  similar+-- to GRIN except for the explicit typing on variables. Note, that certain+-- haskell types become Grin values, however, nothing may be done with types other+-- than examining them. (types may not be constructed at run-time)++infixr 1  :->, :>>=++-- The basic operations of our monad+--+-- PeekVal and PokeVal differ from the primitive peek and poke in that the Val+-- varients operate on node references, while the primitive versions work on+-- raw memory with unboxed pointers.+--++data BaseOp+    = Demote                -- turn a node into an inode, always okay+    | Promote               -- turn an inode into a node, the inode _must_ already be a valid node+    | Eval                  -- evaluate an inode, returns a node representing the evaluated value. Bool is whether to update the inode+    | Apply [Ty]            -- apply a partial application to a value, returning the given type+    | StoreNode !Bool       -- create a new node, Bool is true if it should be a direct node, the second val is the region+    | Redirect              -- write an indirection over its first argument to point to its second one+    | Overwrite             -- overwrite an existing node with new data (the tag must match what was used for the initial Store)+    | PeekVal               -- read a value from a pointed to location+    | PokeVal               -- write a value to a pointed to location+    | Consume               -- consume a value, depending on the back end this may be used to free memory+    | GcTouch               -- touch a value, forcing the GC to hold onto it.+    | Coerce Ty             -- coerce one type to another, danger zone. This is for reflection/rts and not for integral conversions.+    | GcPush                -- push some pointers onto the GC stack, returning registers representing the values on the stack+    | NewRegister           -- create a new register+    | ReadRegister          -- read a register+    | WriteRegister         -- write to a register+    deriving(Eq,Ord,Show)++data Lam = [Val] :-> Exp+    deriving(Eq,Ord,Show)++data Exp =+     Exp :>>= Lam                                                         -- ^ Sequencing - the same as >>= for monads.+    | BaseOp    { expBaseOp :: BaseOp,+                  expArgs :: [Val]+                }+    | App       { expFunction  :: Atom,+                  expArgs :: [Val],+                  expType :: [Ty] }                                       -- ^ Application of functions and builtins+    | Prim      { expPrimitive :: Prim,+                  expArgs :: [Val],+                  expType :: [Ty] }                                       -- ^ Primitive operation+    | Case      { expValue :: Val, expAlts :: [Lam] }                     -- ^ Case statement+    | Return    { expValues :: [Val] }                                    -- ^ Return a value+    | Error     { expError :: String, expType :: [Ty] }                   -- ^ Abort with an error message, non recoverably.+    | Call      { expValue :: Val,+                  expArgs :: [Val],+                  expType :: [Ty],+                  expJump :: Bool,                                        -- ^ Jump is equivalent to a call except it deallocates the region it resides in before transfering control+                  expFuncProps :: FuncProps,+                  expInfo :: Info.Info }                                  -- ^ Call or jump to a callable+    | NewRegion { expLam :: Lam, expInfo :: Info.Info }                   -- ^ create a new region and pass it to its argument+    | Alloc     { expValue :: Val,+                  expCount :: Val,+                  expRegion :: Val,+                  expInfo :: Info.Info }                                  -- ^ allocate space for a number of values in the given region+    | Let       { expDefs :: [FuncDef],+                  expBody :: Exp,+                  expFuncCalls :: (Set.Set Atom,Set.Set Atom),            -- ^ cache+                  expIsNormal :: Bool,                                    -- ^ cache, True = definitely normal, False = maybe normal+                  expNonNormal :: Set.Set Atom,                           -- ^ cache, a superset of functions called in non-tail call position.+                  expInfo :: Info.Info }                                  -- ^ A let of local functions+    | MkClosure { expValue :: Val,+                  expArgs :: [Val],+                  expRegion :: Val,+                  expType :: [Ty],+                  expInfo :: Info.Info }                   -- ^ create a closure+    | MkCont    { expCont :: Lam,                          -- ^ the continuation routine+                  expLam :: Lam,                           -- ^ the computation that is passed the newly created computation+                  expInfo :: Info.Info }                   -- ^ Make a continuation, always allocated on region encompasing expLam+    | GcRoots   { expValues :: [Val],                  -- ^ add some new variables to the GC roots for a subcomputation+                  expBody :: Exp }+    deriving(Eq,Show,Ord)++data Val =+    NodeC !Tag [Val]          -- ^ Complete node, of type TyNode+    | Const Val               -- ^ constant data, only Lit, Const and NodeC may be children. of type TyINode+    | Lit !Number Ty          -- ^ Literal+    | Var !Var Ty             -- ^ Variable+    | Unit                    -- ^ Empty value used as placeholder+    | ValPrim Prim [Val] Ty   -- ^ Primitive value+    | Index Val Val           -- ^ A pointer incremented some number of values (Index v 0) == v+    | Item Atom Ty            -- ^ Specific named thing. function, global, region, etc..+    | ValUnknown Ty           -- ^ Unknown or unimportant value+    deriving(Eq,Ord)++data Ty =+    TyPtr Ty                     -- ^ pointer to a memory location which contains its argument+    | TyNode                     -- ^ a whole node+    | TyINode                    -- ^ a whole possibly indirect node+    | TyAttr Ty Ty               -- ^ attach an attribute to a type+    | TyAnd Ty Ty                -- ^ boolean conjunction of types+    | TyOr  Ty Ty                -- ^ boolean disjunction of types+    | TyPrim Op.Ty               -- ^ a basic type+    | TyUnit                     -- ^ type of Unit+    | TyCall Callable [Ty] [Ty]  -- ^ something call,jump, or cut-to-able+    | TyRegion                   -- ^ a region+    | TyGcContext                -- ^ the context for garbage collection+    | TyRegister Ty              -- ^ a register contains a mutable value, the register itself cannot be addressed,+                                 --   hence they may not be returned from functions or passed as arguments.+    | TyComplex Ty               -- ^ A complex version of a basic type+    | TyVector !Int Ty           -- ^ A vector of a basic type+    | TyUnknown                  -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation+    deriving(Eq,Ord)++data Callable = Continuation | Function | Closure | LocalFunction | Primitive'+    deriving(Eq,Ord,Show)++type Tag = Atom++newtype Var = V Int+    deriving(Eq,Ord,Enum)++data FuncDef = FuncDef {+    funcDefName  :: Atom,+    funcDefBody  :: Lam,+    funcDefCall  :: Val,+    funcDefProps :: FuncProps+    } deriving(Eq,Ord,Show)++-- Type information table (TyEnv)++data TyThunk+    = TyNotThunk               -- ^ not the thunk+    | TyPApp (Maybe Ty) Atom   -- ^ can be applied to (possibly) an argument, and what results+    | TySusp Atom              -- ^ can be evaluated and calls what function+    deriving(Eq,Show)++data TyTy = TyTy {+    tySlots :: [Ty],+    tyReturn :: [Ty],+    tyThunk :: TyThunk,+    tySiblings :: Maybe [Atom]+}++tyTy = TyTy { tySlots = [], tyReturn = [], tySiblings = Nothing, tyThunk = TyNotThunk }++newtype TyEnv = TyEnv (GMap Atom TyTy)+    deriving(Monoid)++-- random utility values++lamExp (_ :-> e) = e+lamBind (b :-> _) = b++isVar Var {} = True+isVar _ = False++tagHole = toAtom "@hole"++gEval :: Val -> Exp+gEval x = BaseOp Eval [x]++tyINode = TyINode -- ^ lazy node sptr_t+tyDNode = TyNode  -- ^ strict node wptr_t++createFuncDef local name body@(args :-> rest)  = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where+    call = Item name (TyCall (if local then LocalFunction else Function) (map getType args) (getType rest))++updateFuncDefProps fd@FuncDef { funcDefBody = body@(args :-> rest) } =  fd { funcDefProps = props } where+    props = (funcDefProps fd) { funcFreeVars = freeVars body, funcTags = freeVars body, funcType = (map getType args,getType rest) }++grinFuncs grin = map (\x -> (funcDefName x, funcDefBody x)) (grinFunctions grin)+setGrinFunctions xs _grin | flint && hasRepeatUnder fst xs = error $ "setGrinFunctions: grin has redundent definitions" ++ show (fsts xs)+setGrinFunctions xs grin = grin { grinFunctions = map (uncurry (createFuncDef False)) xs }++extendTyEnv ds (TyEnv env) = TyEnv (fromList xs `mappend` env) where+    xs = [ (funcDefName d,tyTy { tySlots = ss, tyReturn = r }) |  d <- ds, let (ss,r) = funcType $ funcDefProps d]+      ++ [ (tagFlipFunction (funcDefName d),tyTy { tySlots = ss, tyReturn = r }) |  d <- ds, let (ss,r) = funcType $ funcDefProps d, r == [TyNode]]++-- cached info+data FuncProps = FuncProps {+    funcInfo    :: Info.Info,+    funcFreeVars :: Set.Set Var,+    funcTags    :: Set.Set Tag,+    funcType    :: ([Ty],[Ty]),+    funcExits   :: Perhaps,      -- ^ function quits the program+    funcCuts    :: Perhaps,      -- ^ function cuts to a value+    funcAllocs  :: Perhaps,      -- ^ function allocates memory+    funcCreates :: Perhaps,      -- ^ function allocates memory and stores or returns it+    funcLoops   :: Perhaps       -- ^ function may loop+    }+    deriving(Eq,Ord,Show)++funcProps = FuncProps {+    funcInfo = mempty,+    funcFreeVars = mempty,+    funcTags = mempty,+    funcType = undefined,+    funcExits = Maybe,+    funcCuts = Maybe,+    funcAllocs = Maybe,+    funcCreates = Maybe,+    funcLoops = Maybe+    }++data Phase = PhaseInit | PostInlineEval | PostAeOptimize | PostDevolve+    deriving(Show,Eq,Ord,Enum)++phaseEvalInlined e = e >= PostInlineEval++data Grin = Grin {+    grinEntryPoints :: GMap Atom FfiExport,+    grinPhase :: !Phase,+    grinTypeEnv :: TyEnv,+    grinFunctions :: [FuncDef],+    grinSuspFunctions :: Set.Set Atom,+    grinPartFunctions :: Set.Set Atom,+    grinStats :: !Stats.Stat,+    grinCafs :: [(Var,Val)]+}++emptyGrin = Grin {+    grinEntryPoints = mempty,+    grinPhase = PhaseInit,+    grinTypeEnv = mempty,+    grinFunctions = [],+    grinSuspFunctions = mempty,+    grinPartFunctions = mempty,+    grinStats = mempty,+    grinCafs = mempty+}++grinEntryPointNames = keys . grinEntryPoints++data TagInfo+    = TagPApp !Int !Atom   -- partial application, number is how many more arguments needed+    | TagSusp !Bool !Atom  -- a suspended version of the function, true if an update is required+    | TagDataCons          -- data constructor+    | TagTypeCons          -- type constructor+    | TagTypePApp !Int Tag -- type partial app+    | TagFunc++tagInfo t = case fromAtom t of+    'F':xs -> TagSusp True (toAtom $ 'f':xs)+    'B':xs -> TagSusp True (toAtom $ 'b':xs)+    'f':_  -> TagFunc+    'b':_  -> TagFunc+    'C':_  -> TagDataCons+    'T':_  -> TagTypeCons+    'P':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagPApp (read n) (toAtom $ 'f':xs)+    'Y':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagTypePApp (read n) (toAtom $ 'T':xs)+    t -> error $ "tagInfo: bad tag " ++  t++partialTag :: Tag -> Int -> Tag+partialTag v c = case fromAtom v of+    ('f':xs) | 0 <- c ->   toAtom $ 'F':xs+             | c > 0 ->  toAtom $ 'P':show c ++ "_" ++ xs+    ('T':xs) | 0 <- c ->  v+             | c > 0 ->  toAtom $ 'Y':show c ++ "_" ++ xs+    ('b':xs) | 0 <- c ->  toAtom $ 'B':xs+    _ -> error $  "partialTag: " ++ show (v,c)++tagUnfunction :: Monad m => Tag -> m (Int, Tag)+tagUnfunction t+    | tagIsSuspFunction t = return (0,tagFlipFunction t)+    | tagIsFunction t = return (0,t)+    | ('P':zs) <- t', (n@(_:_),'_':rs) <- span isDigit zs = return (read n, toAtom ('f':rs))+    where t' = fromAtom t+tagUnfunction _ = fail "Tag does not represent function"++tagFlipFunction t+    | 'F':xs <- t' = toAtom $ 'f':xs+    | 'B':xs <- t' = toAtom $ 'b':xs+    | 'f':xs <- t' = toAtom $ 'F':xs+    | 'b':xs <- t' = toAtom $ 'B':xs+    | otherwise = error "Cannot FLIP non function."+    where t' = fromAtom t++tagIsSuspFunction t+    | 'F':_ <- t' = True+    | 'B':_ <- t' = True+    | otherwise = False+    where t' = fromAtom t++tagToFunction t+    | 'F':xs <- t' = return $ toAtom $ 'f':xs+    | 'B':xs <- t' = return $ toAtom $ 'b':xs+    | 'f':_ <- t' = return t+    | 'b':_ <- t' = return t+    | 'P':is <- t', ('_':xs) <- dropWhile isDigit is = return $ toAtom $ 'f':xs+    | otherwise = fail $ "Not Function: " ++ t'+    where t' = fromAtom t++tagIsFunction t+    | 'f':_ <- t' = True+    | 'b':_ <- t' = True+    | otherwise = False+    where t' = fromAtom t++tagIsPartialAp t+    | 'P':_ <- t' = True+    | otherwise = False+    where t' = fromAtom t++tagIsTag t+    | 'P':_ <- t' = True+    | 'T':_ <- t' = True+    | 'C':_ <- t' = True+    | 'F':_ <- t' = True+    | 'B':_ <- t' = True+    | 'Y':_ <- t' = True+    | otherwise = False+    where t' = fromAtom t++tagIsWHNF t+    | 'P':_ <- t' = True+    | 'T':_ <- t' = True+    | 'C':_ <- t' = True+    | 'Y':_ <- t' = True+    | otherwise = False+    where t' = fromAtom t++valIsNF (NodeC t vs) = tagIsWHNF t && all valIsNF vs+valIsNF Const {} = True+valIsNF Lit {} = True+valIsNF _ = False++properHole x = case x of+    TyINode -> Const (properHole TyNode)+    ty@(TyPrim _) -> (Lit 0 ty)+    ~TyNode -> (NodeC tagHole [])++isHole x = x `elem` map properHole [TyINode, TyNode]++isValUnknown ValUnknown {} = True+isValUnknown _ = False++---------+-- Look up stuff in the typing environment.+---------++findTyTy (TyEnv m) a | Just tyty <-  mlookup a m = return tyty+findTyTy (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case mlookup (toAtom ('T':rs)) m of+    Just TyTy { tySlots = ts, tyReturn = n } -> return tyTy { tySlots = take (length ts - read ns) ts, tyReturn = n }+    Nothing -> fail $ "findArgsType: " ++ show a+findTyTy _ a | "@hole" `isPrefixOf` fromAtom a  = return tyTy { tySlots = [], tyReturn = [TyNode] }+findTyTy _ a =  fail $ "findArgsType: " ++ show a++findArgsType m a = liftM (\tyty -> (tySlots tyty,tyReturn tyty)) (findTyTy m a)++findArgs m a = case findArgsType m a of+    Nothing -> fail $ "findArgs: " ++ show a+    Just (as,_) -> return as++v0 = V 0+v1 = V 1+v2 = V 2+v3 = V 3++n0 = Var v0 TyNode+n1 = Var v1 TyNode+n2 = Var v2 TyNode+n3 = Var v3 TyNode++p0 = Var v0 TyINode+p1 = Var v1 TyINode+p2 = Var v2 TyINode+p3 = Var v3 TyINode++-- CanType instances++instance CanType Exp where+    type TypeOf Exp = [Ty]+    getType (_ :>>= (_ :-> e2)) = getType e2+    getType (Prim _ _ ty) = ty+    getType App { expType = t } = t+    getType (BaseOp Overwrite _) = []+    getType (BaseOp GcTouch _) = []+    getType (BaseOp (Coerce t) _) = [t]+    getType (BaseOp Redirect _) = []+    getType (BaseOp Promote _) = [TyNode]+    getType (BaseOp Demote _) = [TyINode]+    getType (BaseOp Eval _) = [TyNode]+    getType (BaseOp (StoreNode b) _) = if b then [TyNode] else [TyINode]+    getType (BaseOp NewRegister xs) = map (TyRegister . getType) xs+    getType (BaseOp WriteRegister _) = []+    getType (BaseOp ReadRegister [r]) = case getType r of+        TyRegister t -> [t]+        _ -> error "Exp.getType: ReadRegister of non register"+    getType (BaseOp (Apply ty) _) = ty+    getType (BaseOp PeekVal [v]) = case getType v of+        TyPtr t -> [t]+        _ -> error "Exp.getType: PeekVal of non-pointer type"+    getType (Return v) = getType v+    getType (Error _ t) = t+    getType (Case _ []) = error "empty case"+    getType (Case _ ((_ :-> e):_)) = getType e+    getType NewRegion { expLam = _ :-> body } = getType body+    getType Alloc { expValue = v } = [TyPtr (getType v)]+    getType Let { expBody = body } = getType body+    getType MkCont { expLam = _ :-> rbody } = getType rbody+    getType Call { expType = ty } = ty+    getType MkClosure { expType = ty } = ty+    getType GcRoots { expBody = body } = getType body+    getType _ = error "Exp.getType: bad."++instance CanType Val where+    type TypeOf Val = Ty+    getType (Var _ t) = t+    getType (Lit _ t) = t+    getType (Index v _) = getType v+    getType Unit = TyUnit+    getType (Const t) = case (getType t) of+        TyNode -> TyINode+        t -> error "Val.getType: Const of non-node"+    getType (NodeC {}) = TyNode+    getType (ValPrim _ _ ty) = ty+    getType (ValUnknown ty) = ty+    getType (Item _ ty) = ty++-- FreeVars instances++instance FreeVars Lam (Set.Set Var) where+    freeVars (x :-> y) = freeVars y Set.\\ freeVars x+instance FreeVars Lam (Set.Set (Var,Ty)) where+    freeVars (x :-> y) = freeVars y Set.\\ freeVars x++instance  FreeVars Exp (Set.Set Var,Set.Set Tag) where+    freeVars x = (freeVars x, freeVars x)++instance FreeVars Val (Set.Set Var) where+    freeVars (NodeC t xs) = freeVars xs+    freeVars (Const v) = freeVars v+    freeVars (Index a b) = freeVars (a,b)+    freeVars (Var v _) = Set.singleton v+    freeVars _ = Set.empty++instance FreeVars Val (Set.Set (Var,Ty)) where+    freeVars (NodeC t xs) = freeVars xs+    freeVars (Const v) = freeVars v+    freeVars (Index a b) = freeVars (a,b)+    freeVars (Var v t) = Set.singleton (v,t)+    freeVars _ = Set.empty++instance FreeVars FuncProps (Set.Set Var) where+    freeVars FuncProps { funcFreeVars = fv } = fv++instance FreeVars FuncProps (Set.Set Tag) where+    freeVars FuncProps { funcTags = fv } = fv++instance FreeVars FuncProps a => FreeVars FuncDef a where+    freeVars fd = freeVars (funcDefProps fd)++instance FreeVars Exp (Set.Set Var) where+    freeVars (a :>>= b) = freeVars (a,b)+    freeVars (App a vs _) =  freeVars vs+    freeVars (Case x xs) = freeVars (x,xs)+    freeVars (Return v) = freeVars v+--    freeVars (Store v) = freeVars v+    freeVars (BaseOp _ vs) = freeVars vs+    freeVars (Prim _ x _) = freeVars x+    freeVars Error {} = Set.empty+    freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body+    freeVars NewRegion { expLam = l } = freeVars l+    freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)+    freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)+    freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+    freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)++instance FreeVars Exp (Set.Set (Var,Ty)) where+    freeVars (a :>>= b) = freeVars (a,b)+    freeVars (App a vs _) =  freeVars vs+    freeVars (Case x xs) = freeVars (x,xs)+    freeVars (Return v) = freeVars v+--    freeVars (Store v) = freeVars v+    freeVars (BaseOp _ vs) = freeVars vs+    freeVars (Prim _ x _) = freeVars x+    freeVars Error {} = Set.empty+    freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (freeVars . funcDefBody) fdefs) `mappend` freeVars body+    freeVars NewRegion { expLam = l } = freeVars l+    freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)+    freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)+    freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+    freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)++instance FreeVars Val (Set.Set Tag) where+    freeVars (NodeC t xs) = Set.singleton t `Set.union` freeVars xs+    freeVars (Index a b) = freeVars (a,b)+    freeVars (Const v) = freeVars v+    freeVars _ = Set.empty++instance FreeVars Val [Tag] where+    freeVars v = Set.toList $ freeVars v++instance FreeVars Exp [Tag] where+    freeVars v = Set.toList $ freeVars v++instance FreeVars Lam (Set.Set Tag) where+    freeVars (a :-> b) = freeVars (a,b)++instance FreeVars Exp (Set.Set Tag) where+    freeVars (a :>>= b) = freeVars (a,b)+    freeVars (App a vs _) = Set.singleton a `Set.union` freeVars vs+    freeVars (Case x xs) = freeVars (x,xs)+    freeVars (Return v) = freeVars v+--    freeVars (Store v) = freeVars v+    freeVars (BaseOp _ vs) = freeVars vs+    freeVars (Prim _ x _) = freeVars x+    freeVars Error {} = Set.empty+    freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcTags . funcDefProps) fdefs) `mappend` freeVars body+    freeVars NewRegion { expLam = l } = freeVars l+    freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)+    freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)+    freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+    freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)++instance FreeVars Lam (GSet Var) where+    freeVars (x :-> y) = freeVars y \\ freeVars x++instance  FreeVars Exp (GSet Var,GSet Tag) where+    freeVars x = (freeVars x, freeVars x)++instance FreeVars Val (GSet Var) where+    freeVars (NodeC t xs) = freeVars xs+    freeVars (Const v) = freeVars v+    freeVars (Index a b) = freeVars (a,b)+    freeVars (Var v _) = singleton v+    freeVars _ = sempty++instance FreeVars FuncProps (GSet Var) where+    freeVars FuncProps { funcFreeVars = fv } = fromDistinctAscList $ toList fv++instance FreeVars FuncProps (GSet Tag) where+    freeVars FuncProps { funcTags = fv } = fromDistinctAscList $ toList fv++instance FreeVars Exp (GSet Var) where+    freeVars (a :>>= b) = freeVars (a,b)+    freeVars (App a vs _) =  freeVars vs+    freeVars (Case x xs) = freeVars (x,xs)+    freeVars (Return v) = freeVars v+--    freeVars (Store v) = freeVars v+    freeVars (BaseOp _ vs) = freeVars vs+    freeVars (Prim _ x _) = freeVars x+    freeVars Error {} = sempty+    freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (fromDistinctAscList . toList . funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body+    freeVars NewRegion { expLam = l } = freeVars l+    freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)+    freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)+    freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+    freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)++instance FreeVars Exp [Var] where+    freeVars e = toList $ (freeVars e :: GSet Var)+instance FreeVars Val [Var] where+    freeVars e = toList $ (freeVars e :: GSet Var)+instance FreeVars Lam [Var] where+    freeVars e = toList $ (freeVars e :: GSet Var)++instance FreeVars Val (GSet Tag) where+    freeVars (NodeC t xs) = singleton t `union` freeVars xs+    freeVars (Index a b) = freeVars (a,b)+    freeVars (Const v) = freeVars v+    freeVars _ = sempty++instance FreeVars Lam (GSet Tag) where+    freeVars (a :-> b) = freeVars (a,b)++instance FreeVars Exp (GSet Tag) where+    freeVars (a :>>= b) = freeVars (a,b)+    freeVars (App a vs _) = singleton a `union` freeVars vs+    freeVars (Case x xs) = freeVars (x,xs)+    freeVars (Return v) = freeVars v+--    freeVars (Store v) = freeVars v+    freeVars (BaseOp _ vs) = freeVars vs+    freeVars (Prim _ x _) = freeVars x+    freeVars Error {} = sempty+    freeVars Let { expDefs = fdefs, expBody = body } = unions (map (fromDistinctAscList . toList . funcTags . funcDefProps) fdefs) `mappend` freeVars body+    freeVars NewRegion { expLam = l } = freeVars l+    freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)+    freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)+    freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+    freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)++-- Show instances++instance Show Var where+    showsPrec _ (V n) xs = 'v':shows n xs++instance Show Ty where+    showsPrec n (TyComplex ty) = showParen (n >= 9) $ text "Complex" <+> showsPrec 10 ty+    showsPrec n (TyVector v ty) = showParen (n >= 9) $ showsPrec 10 ty <> text "*" <> tshow v+    showsPrec n (TyAttr t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text "#" <> showsPrec 10 t2+    showsPrec n (TyAnd t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text " && " <> showsPrec 10 t2+    showsPrec n (TyOr t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text " || " <> showsPrec 10 t2+    showsPrec _ t = showString (f t) where+        f TyNode = "N"+        f TyINode = "I"+        f (TyPtr t) = '&':show t+        f (TyUnit) = "()"+        f (TyPrim t) = show t+        f TyRegion = "M"+        f TyGcContext = "GC"+        f (TyRegister t) = 'r':show t+        f (TyCall c as rt) = show c <> tupled (map show as) <+> "->" <+> show rt+        f TyUnknown = "?"+        f _ = "BADTYPE"++instance Show Val where+    -- showsPrec _ s | Just st <- fromVal s = text $ show (st::String)+    showsPrec _ (NodeC t []) = parens $ (fromAtom t)+    showsPrec _ (NodeC t vs) = parens $ (fromAtom t) <+> hsep (map shows vs)+    showsPrec _ (Index v o) = shows v <> char '[' <> shows o <> char ']'+    showsPrec _ (Var (V i) t)+        | TyINode <- t = text "ni" <> tshow i+        | TyNode <- t = text "nd" <> tshow i+        | TyRegion <- t = text "m" <> tshow i+        | TyRegister ty <- t = text "r" <> tshow (Var (V i) ty)+        | TyGcContext <- t = text "gc" <> tshow i+        | TyPtr t' <- t = text "p" <> shows (Var (V i) t')+        | TyPrim Op.TyBool <- t  = char 'b' <> tshow i+        | TyPrim (Op.TyBits _ Op.HintFloat) <- t  = char 'f' <> tshow i+        | TyPrim (Op.TyBits _ Op.HintCharacter) <- t  = char 'c' <> tshow i+        | TyPrim (Op.TyBits (Op.Bits 8)  _) <- t  = char 'o' <> tshow i      -- octet+        | TyPrim (Op.TyBits (Op.Bits 16)  _) <- t  = char 'h' <> tshow i     -- half+        | TyPrim (Op.TyBits (Op.Bits 32)  _) <- t  = char 'w' <> tshow i     -- word+        | TyPrim (Op.TyBits (Op.Bits 64)  _) <- t  = char 'd' <> tshow i     -- doubleword+        | TyPrim (Op.TyBits (Op.Bits 128)  _) <- t  = char 'q' <> tshow i    -- quadword+        | TyPrim (Op.TyBits (Op.BitsArch Op.BitsPtr)  _) <- t  = text "bp" <> tshow i+        | TyPrim (Op.TyBits (Op.BitsArch Op.BitsMax)  _) <- t  = text "bm" <> tshow i+        | TyPrim (Op.TyBits _ _) <- t  = char 'l' <> tshow i+        | otherwise = char 'v' <> tshow i+    showsPrec _ (Lit i _)  = tshow i+    showsPrec _ Unit  = showString "()"+    showsPrec _ (Const v) = char '&' <> shows v+    showsPrec _ (Item a  ty) = tshow a <> text "::" <> tshow ty+    showsPrec _ (ValUnknown ty) = text "?::" <> tshow ty+    showsPrec _ (ValPrim aprim xs _) = tshow aprim <> tupled (map tshow xs)++-- misc instances++instance TypeNames Ty where+    tIntzh = TyPrim (Op.bits32)+    tEnumzh = TyPrim (Op.bits16)+    tCharzh = TyPrim (Op.bits32)++instance Intjection Var where+    toIntjection i = V (fromIntegral i)+    fromIntjection (V i) = fromIntegral i++newtype instance GSet Var = GSetVar (IntjectionSet Var)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,Eq,Ord)+newtype instance GMap Var v = GMapVar (IntjectionMap Var v)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike,Eq,Ord)
+ src/Grin/Grin.hs-boot view
@@ -0,0 +1,7 @@+module Grin.Grin where+++data Exp+data Grin+data Val+data Lam
+ src/Grin/HashConst.hs view
@@ -0,0 +1,51 @@+module Grin.HashConst(newConst,HcHash(),HcNode(..),toList,emptyHcHash) where++import Control.Monad.State+import qualified Data.Map as Map+import qualified Data.Set as Set++import Grin.Grin+import StringTable.Atom+import Util.Graph++-- TODO tuples++data HcNode = HcNode {-# UNPACK #-} !Atom [Either Val Int]+    deriving(Show,Ord,Eq)++data HcHash = HcHash !Int (Map.Map HcNode Int)+    deriving(Show)++emptyHcHash = HcHash 1 Map.empty++newConst :: MonadState HcHash m => Set.Set Atom -> Val -> m (Bool,Int)+newConst cpr n = f n where+    f (NodeC t vs) = do+        let g (Lit i ty)+                | otherwise = return $ Left (Lit i ty)+            g vp@(ValPrim _ _ ty)+                | otherwise = return $ Left vp+            g x@(Var (V n) _) | n < 0  = return $ Left x+            g n@(Const (NodeC _ [])) = return $ Left n+            g n@(NodeC _ []) = return $ Left n+            g n@(Const (NodeC a _)) | a `Set.member` cpr = return $ Left n+            g n@(NodeC a _) | a `Set.member` cpr  = return $ Left n+            g (Const n) = liftM (Right . snd) $ f n+            g n@NodeC {} = liftM (Right . snd) $ f n+            g e = error $ "HashConst.g: " ++ show e+        vs' <- mapM g vs+        let n = HcNode t vs'+        HcHash c h <- get+        case Map.lookup n h of+            Just n -> return (True,n)+            Nothing -> do+                let h' = Map.insert n c h+                put $ HcHash (c + 1) h'+                return (False,c)+    f _ = error "HashConst.newConst'"++toList :: HcHash -> [(HcNode,Int)]+toList (HcHash _ mp) = reverse ans where+    gr = newGraph (Map.toList mp) snd (gk . fst)+    gk (HcNode _ xs) = [ i | Right i <- xs]+    ans = topSort gr
+ src/Grin/Interpret.hs view
@@ -0,0 +1,187 @@+module Grin.Interpret(evaluate) where++import C.Prims+import Char+import CharIO+import Control.Monad.Identity+import Data.IORef+import Data.Map as Map hiding(map)+import Data.Monoid+import Doc.DocLike+import Doc.Pretty+import GenUtil hiding(putErrLn,putErr)+import Grin.Grin+import Grin.Show+import Name.VConsts+import Options+import StringTable.Atom+import Support.CanType+import qualified FlagDump as FD+import qualified Stats++type Builtin = [Val] -> IO Val++builtins = []+builtinMap = Map.fromList [ (x,y) | (x,y) <- builtins ]++createCafMap as = f vars [] >>= return . Map.fromList  where+    f [] xs = return xs+    f ((x,y):xs) ys = newIORef y >>= \y -> f xs ((x,Addr y):ys)+    vars = as++evaluate ::  Grin -> IO (Val,Stats.Stats)+evaluate Grin { grinTypeEnv = tyEnv, grinFunctions = ts, grinCafs = cafs } =  do+    stats <- Stats.new+    cafMap <- createCafMap cafs+    let f x = interpret stats tyEnv cafMap builtinMap (fromList  ts) x+        g (App t [l@Lit {}] _) | t == funcEval = return l+        g (App t [Const n] _) | t == funcEval = return n+        g e = f e >>= \x -> case x of+            NodeC t xs -> do+                xs <- mapM (g . gEval) xs+                return $ NodeC t xs+            z -> return z+    v <- g (App funcMain [] tyUnit)+    return (v,stats)++funcCalls = toAtom "Function Calls"+primCalls = toAtom "Primitive Calls"++prettyEnv env = vcat [ text ('v':show x) <+> text "->" <+> prettyVal y | (V x,y) <-  Map.toList env ]++interpret ::  Stats.Stats -> TyEnv -> Map Var Val -> Map Atom Builtin -> Map Atom Lam  -> Exp -> IO Val+interpret stats te cafMap primMap scMap e = f mempty e where+    f :: Map Var Val -> Exp -> IO Val+    f env (e1 :>>= (v :-> e2)) = do+        r <- f env e1+        be <- bind v r+        f (be `mappend` env) e2+    f env (App a xs ty) = do+        wdump FD.Steps $ do+            putErrLn $ render (prettyExp mempty $ App a xs' ty)+        Stats.tick stats funcCalls+        Stats.tick stats (toAtom $ "Function." ++ fromAtom a)+        case Map.lookup a scMap of+            Nothing -> error $ "Unknown App: " ++ show (App a xs' ty)+            Just ((Tup as :-> e)) -> f (Map.fromList (zip [ v | Var v _ <- as] xs')) e+      where xs' = map (le env) xs+    f env (Prim Primitive { primAPrim = APrim CCast {} _, primType = (_,t)} [x]) = return $ (Lit n t)+        where (Lit n _) = le env x+    f env (Prim Primitive { primAPrim = APrim Func { funcName = "putwchar" } _} [x]) = putChar (chr $ fromIntegral n) >> return unit+        where (Lit n _) = le env x+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "<=" } _, primType = (_,t)} [x,y]) = if x' <= y' then return (Lit 1 t) else return (Lit 0 t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = ">=" } _, primType = (_,t)} [x,y]) = if x' >= y' then return (Lit 1 t) else return (Lit 0 t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = ">" } _, primType = (_,t)} [x,y]) = if x' > y' then return (Lit 1 t) else return (Lit 0 t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "<" } _, primType = (_,t)} [x,y]) = if x' < y' then return (Lit 1 t) else return (Lit 0 t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "==" } _, primType = (_,t)} [x,y]) = if x' == y' then return (Lit 1 t) else return (Lit 0 t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "+" } _, primType = (_,t)} [x,y]) = return (Lit (x' + y') t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "/" } _, primType = (_,t)} [x,y]) = return (Lit (x' `div` y') t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "%" } _, primType = (_,t)} [x,y]) = return (Lit (x' `mod` y') t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "-" } _, primType = (_,t)} [x,y]) = return (Lit (x' - y') t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "*" } _, primType = (_,t)} [x,y]) = return (Lit (x' * y') t)+        where (Lit x' _) = le env x+              (Lit y' _) = le env y+    f env (Prim Primitive { primAPrim = APrim Operator { primOp = "-" } _, primType = (_,t)} [x]) = return (Lit (negate x') t)+        where (Lit x' _) = le env x+    f env (Prim p xs) = do+        let a = primName p+            xs' = map (le env) xs+        wdump FD.Steps $ do+            putErrLn $ render (prettyExp mempty $ Prim p xs')+        Stats.tick stats primCalls+        Stats.tick stats (toAtom $ "Primitive." ++ fromAtom a)+        case Map.lookup a primMap of+            Nothing -> error $ "Unknown Primitive: " ++ show (Prim p xs')+            Just action -> do action xs'+    f env (Return v) = return (le env v)+    f env (Store v) = do+        Stats.tick stats (toAtom "Allocations Performed")+        fmap Addr $ newIORef (le env v)+    f env (Fetch x)+        | (Addr x) <- le env x = readIORef x+        | (Const x) <- le env x  = return x+    f env (Update x v) | (Addr x) <- le env x = do+        Stats.tick stats (toAtom "Updates Performed")+        (writeIORef x $! (le env v)) >> return unit+    f env (Update x v) | (Const x) <- le env x, x == le env v =  return unit+    f env (Update x v)  = fail $ "Bad update: " ++ show (le env x,le env v)+    f env (Error s t) = fail $ render $  tshow (s,t) <$> (prettyEnv env)+--    f env (Eval x)+--        | otherwise = f env $ App funcEval [x]+--        | Const x <- lx = doEval x+--        | (Addr ref) <- lx = do+--            v <- readIORef ref+--            nv <- doEval v+--            writeIORef ref nv+--            return nv+--        where+--            lx = le env x+--    f env (Apply x y)+--        | True =  f env $ App funcApply [x,y]+--        | False = doApply (le env x) (le env y)+    f env (Case v ps) = match (le env v) ps where+        match s ((p :-> e):ps) = case bind p s of+            Nothing -> match s ps+            Just env' -> f (env' `mappend` env) e+        match e [] = fail $ "end of match: " ++ show e <+> show env+    f env z = fail $ "cannot interpret: " ++ show (toList env,z)+    le env (Tup vs) = Tup (map (le env) vs)+    le env (NodeC t vs) = NodeC t (map (le env) vs)+    le env z@(NodeV t vs) = NodeC (lt t) (map (le env) vs)  where+        lt x = case Map.lookup x env of+            Just (Tag t) -> t+            z' -> error $ "Invalid tag variable in NodeV: " ++ show (z,z')+    le env z@(Var v _) = case Map.lookup v env `mplus` Map.lookup v cafMap of+        Just x -> le env x+        Nothing -> error $ "le" ++ show (z,env)+    le _ x = x++    doApply (NodeC t xs) y+        | n == (1::Int) = f mempty (App (toAtom $ 'f':rs) (xs ++ [y]) TyNode)  -- TODO, right?+        | n > 1 = return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (xs ++ [y])+        where+        ('P':cs) = fromAtom t+        (n','_':rs) = span isDigit cs+        n = read n'+    doApply x y = error $ "doApply " ++ show (x,y)+    doEval x@(NodeC t xs)+        | 'P':_ <- t' = return x+        | 'T':_ <- t' = return x+        | 'C':_ <- t' = return x+        | 'F':rs <- t' = f mempty (App (toAtom $ 'f':rs) xs TyNode)  -- TODO, right?+        | 'B':rs <- t' = f mempty (App (toAtom $ 'b':rs) xs TyNode)  -- TODO, right?+        where+        t' = fromAtom t+    doEval x = error $ "doEval " ++ show x++    bind :: Monad m => Val -> Val -> m (Map Var Val)+    bind (Var (V 0) _) _ = return mempty+    bind (Var v _) r = return $ singleton v r+    bind (Lit i _) (Lit i' _) | i == i' = return mempty+    bind (Tup xs) (Tup ys) = liftM mconcat $ sequence $  zipWith bind xs ys+    bind (Tag i) (Tag i') | i == i' = return mempty+    bind (NodeV v vs) (NodeC t vs') = do+        be <- liftM mconcat $ sequence $  zipWith bind vs vs'+        return (be `mappend` singleton v (Tag t))+    bind (NodeC t vs) (NodeC t' vs') | t == t' = do+        liftM mconcat $ sequence $  zipWith bind vs vs'+    bind v r | getType v == getType r = fail $ "unbindable: "  ++ show (v,r,getType v,getType r)   -- check type to be sure+    bind x y = error $ "bad bind: " ++ show (x,y)
+ src/Grin/Lint.hs view
@@ -0,0 +1,329 @@+module Grin.Lint(+    lintCheckGrin,+    typecheckGrin,+    transformGrin,+    dumpGrin+    ) where++import Control.Exception+import Control.Monad.Reader+import Data.Monoid+import System.IO+import qualified Data.Set as Set++import Doc.DocLike+import Grin.Grin+import Grin.Show+import Options+import Support.CanType+import Support.Compat+import Support.FreeVars+import Support.Transform+import Text.Printf+import Util.Gen+import Util.SetLike+import qualified FlagDump as FD+import qualified Stats++lintCheckGrin grin = when flint $ typecheckGrin grin++lintCheckGrin' onerr grin | flint = do+    let env = TcEnv { envTyEnv = grinTypeEnv grin, envInScope = fromList (fsts $ grinCafs grin) }+    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,runTc env (tcLam Nothing c))  | a@(_,c) <-  grinFuncs grin ]]+    if null errs then return () else do+    onerr+    putErrLn ">>> Type Errors"+    mapM_ putErrLn  errs+    unless (null errs || optKeepGoing options) $ fail "There were type errors!"+lintCheckGrin' _ _ = return ()++typecheckGrin grin = do+    let env = TcEnv { envTyEnv = grinTypeEnv grin, envInScope = fromList (fsts $ grinCafs grin) }+    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,runTc env (tcLam Nothing c))  | a@(_,c) <-  grinFuncs grin ]]+    mapM_ putErrLn  errs+    unless (null errs || optKeepGoing options) $ fail "There were type errors!"++{-# NOINLINE dumpGrin #-}+dumpGrin pname grin = do+    (argstring,sversion) <- getArgString++    let fn ext action = do+            let oname = outputName ++ "_" ++ pname ++ "." ++ ext+            putErrLn $ "Writing: " ++ oname+            h <- openFile oname WriteMode+            action h+            hClose h+    fn "grin" $ \h -> do+        hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]+        hPrintGrin h grin+    wdump FD.GrinDatalog $ fn "datalog" $ \h -> do+        hPutStrLn h $ unlines [ "% " ++ argstring,"% " ++ sversion,""]+        hPrintGrinDL h grin+    wdump FD.Grin $ do+        putErrLn $ "v-- " ++ pname ++ " Grin"+        printGrin grin+        putErrLn $ "^-- " ++ pname ++ " Grin"++class DShow a where+    dshow :: a -> String++instance DShow String where+    dshow s = '\'':f s where+        f ('\'':rs) = "''" ++ f rs+        f (x:xs) = x:f xs+        f [] = "'"++instance DShow Tag where+    dshow s = '\'':f (show s) where+        f ('\'':rs) = "''" ++ f rs+        f (x:xs) = x:f xs+        f [] = "'"++instance DShow Var where+    dshow v = dshow (show v)++instance DShow Ty where+    dshow v = dshow $ show v++instance (DShow a,DShow b) => DShow (Either a b) where+    dshow (Left x) = dshow x+    dshow (Right x) = dshow x++funArg n i = show n ++ "@arg@" ++ show i+funRet n i = show n ++ "@ret@" ++ show i++printFunc h n (l :-> e) = do+    hPrintf h "func(%s,%i).\n" (dshow n) (length l)+    forM_ (zip naturals l) $ \ (i,Var v t) -> do+        hPrintf h "perform(assign,%s,%s).\n" (dshow v) (dshow $ funArg n i)+        hPrintf h "what(%s,funarg).\n" (dshow $ funArg n i)+        hPrintf h "typeof(%s,%s).\n" (dshow $ funArg n i) (dshow t)+        hPrintf h "typeof(%s,%s).\n" (dshow v) (dshow t)+    let rts = getType e+        lts = [ (t,funRet n i) | t <- rts | i <- naturals ]+    mapM_ (hPrintf h "what(%s,funret).\n" . dshow) (snds lts)+    mapM_ (\ (t,n) -> hPrintf h "typeof(%s,%s).\n" (dshow n) (dshow t)) lts+    printDL h n (map (Left . snd) lts) e++hPrintGrinDL :: Handle -> Grin -> IO ()+hPrintGrinDL h grin = do+    let cafs = grinCafs grin+    when (not $ null cafs) $ do+        hPutStrLn h "% cafs"+        mapM_ (\ (x,y) -> hPrintf h "what(%s,'caf').\ntypeof(%s,inode).\n" (dshow x) (dshow x))  cafs+    hPutStrLn h "% functions"+    forM_ (grinFuncs grin) $ \ (n,l :-> e) -> printFunc h n (l :-> e)++bindUnknown h l r = do+    mapM_ (\ (x,t) -> when (tyInteresting t) $ setUnknown h x r) (Set.toList $ freeVars l :: [(Var,Ty)])++setUnknown :: DShow a => Handle -> a -> String -> IO ()+setUnknown h x r = do hPrintf h "unknown(%s,%s).\n" (dshow x) (dshow r)++printDL h n fs e = f fs e where+    f fs (x :>>= l :-> y) = do+        f (map Right l) x+        f fs y+    f bs (Return vs) = do zipWithM_ (assign "assign") bs vs+--    f [Left b] (Store (NodeC n vs)) = hPrintf h "store(%s,%s,%s).\n" (dshow b) (dshow n) (if tagIsWHNF n then "true" else "false")+--    f [Right (Var b _)] (Store (NodeC n vs)) = hPrintf h "store(%s,%s,%s).\n" (dshow b) (dshow n) (if tagIsWHNF n then "true" else "false") >> app n vs+--    f [b] (Store x@Var {}) = do assign "demote" b x+    f [b] (BaseOp Eval [x]) = do assign "eval" b x+    f b (App fn as ty) = do+        forM_ (zip naturals as) $ \ (i,a) -> do+            assign "assign" (Left $ funArg fn i) a+        forM_ (zip naturals b) $ \ (i,a) -> do+            genAssign "assign" a (Left $ funRet fn i)+    f b (Case v ls) = mapM_ (\l -> f b (Return [v] :>>= l)) ls+    f b Let { expDefs = defs, expBody = body } = do+        forM_ defs $ \d -> printFunc h (funcDefName d) (funcDefBody d)+        forM_ defs $ \d -> hPrintf h "subfunc(%s,%s).\n" (dshow $ funcDefName d) (dshow n)+        f b body+    f b Error {} = return ()+    f b Call { expValue = Item fn _, expArgs =  as, expType = ty} = do+        forM_ (zip naturals as) $ \ (i,a) -> do+            assign "assign" (Left $ funArg fn i) a+        forM_ (zip naturals b) $ \ (i,a) -> do+            genAssign "assign" a (Left $ funRet fn i)++    f bs e = do zipWithM_ (assign "assign") bs (map ValUnknown (getType e))+    --app n as | Just (0,fn) <- tagUnfunction n = do+    --    hPrintf h "lazyfunc(%s).\n" (dshow fn)+    --    forM_ (zip naturals as) $ \ (i,a) -> do+    --        assign "assign" (Left $ funArg fn i) a+    --app _ _ = return ()+    assign op b v = genAssign op b (Right v)++    genAssign :: String -> Either String Val -> Either String Val -> IO ()+    genAssign op (Left b) (Left l) = hPrintf h "perform(%s,%s,%s).\n" op (dshow b) (dshow l)+    genAssign op (Right (Var v1 _)) (Left l) = hPrintf h "perform(%s,%s,%s).\n" op (dshow v1) (dshow l)+    genAssign op (Left b) (Right (Var v _)) = hPrintf h "perform(%s,%s,%s).\n" op (dshow b) (dshow v)+    genAssign op (Left b) (Right (Const {})) = hPrintf h "perform(%s,%s,%s).\n" op (dshow b) "const"+    genAssign op (Right (Var v1 _)) (Right (Var v2 _)) = hPrintf h "perform(%s,%s,%s).\n" op (dshow v1) (dshow v2)+    genAssign op (Left b) (Right v) = when (tyInteresting $ getType v) $ setUnknown h b (show (op,v))+    genAssign op (Right b) rv =  bindUnknown h b (take 20 $ show (op,rv))++tyInteresting ty = ty == TyNode || ty == tyINode++transformGrin :: TransformParms Grin -> Grin -> IO Grin++transformGrin TransformParms { transformIterate = IterateMax n } prog | n <= 0 = return prog+transformGrin TransformParms { transformIterate = IterateExactly n } prog | n <= 0 = return prog+transformGrin tp prog = do+    let dodump = transformDumpProgress tp+        name = transformCategory tp ++ pname (transformPass tp) ++ pname (transformName tp)+        _scname = transformCategory tp ++ pname (transformPass tp)+        pname "" = ""+        pname xs = '-':xs+        iterate = transformIterate tp+    when dodump $ putErrLn $ "-- " ++ name+    let ferr e = do+        putErrLn $ "\n>>> Exception thrown"+        putErrLn $ "\n>>> Before " ++ name+        dumpGrin ("lint-before-" ++ name) prog+        putErrLn $ "\n>>>"+        putErrLn (show (e::SomeException'))+        maybeDie+        return prog+    let istat = grinStats prog+    prog' <- Control.Exception.catch (transformOperation tp prog { grinStats = mempty } >>= Control.Exception.evaluate ) ferr+    let estat = grinStats prog'+    let onerr grin' = do+            putErrLn $ "\n>>> Before " ++ name+            dumpGrin ("lint-before-" ++ name) prog+            Stats.printStat name estat+            putErrLn $ "\n>>> After " ++ name+            dumpGrin ("lint-after-" ++ name) grin'+    if transformSkipNoStats tp && Stats.null estat then do+        when dodump $ putErrLn "program not changed"+        return prog+     else do+    when (dodump && not (Stats.null estat)) $ Stats.printStat  name estat+    lintCheckGrin' (onerr prog') prog'+    let tstat = istat `mappend` estat+    if doIterate iterate (not $ Stats.null estat) then transformGrin tp { transformIterate = iterateStep iterate } prog' { grinStats = tstat } else return prog' { grinStats = tstat }+--    if doIterate iterate (estat /= mempty) then transformGrin tp { transformIterate = iterateStep iterate } prog' { progStats = istat `mappend` estat } else+--        return prog' { progStats = istat `mappend` estat, progPasses = name:progPasses prog' }++maybeDie = case optKeepGoing options of+    True -> return ()+    False -> putErrDie "Internal Error"++data TcEnv = TcEnv {+    envTyEnv :: TyEnv,+    envInScope :: Set.Set Var+}++newtype Tc a = Tc (ReaderT TcEnv (Either String) a)+    deriving(Monad,MonadReader TcEnv)++tcErr :: String -> Tc a+tcErr s = Tc $ lift (Left s)++runTc :: TcEnv -> Tc a -> Either String a+runTc env (Tc r) = runReaderT r env++same _ t1 t2 | t1 == t2 = return t1+same msg t1 t2 = tcErr $ "Types not the same:" <+> parens msg <+> parens (tshow t1) <+> parens (tshow t2)++tcLam :: Maybe [Ty] -> Lam -> Tc [Ty]+tcLam mty (v :-> e) = f mty where+    f Nothing = ans (mapM tcVal v)+    f (Just ty) = ans $ do+        t <- mapM tcVal v+        same (":->" <+> show mty <+> show (v :-> e)) ty t+    ans r = local (\e -> e { envInScope = freeVars v `mappend` envInScope e }) $ r >> tcExp e++tcExp :: Exp -> Tc [Ty]+tcExp e = f e where+    f (e :>>= lam) = do+        t1 <- f e+        tcLam (Just t1) lam+    f n@(Prim p as t') = do+        mapM_ tcVal as+        return t'+    f ap@(BaseOp (Apply t) vs) = do+        (v':_) <- mapM tcVal vs+        if v' == TyNode then return t+         else tcErr $ "App apply arg doesn't match: " ++ show ap+    f ap@(BaseOp Eval [v]) = do+        v' <- tcVal v+        if v' == tyINode then return [TyNode]+         else tcErr $ "App eval arg doesn't match: " ++ show ap+    f a@(App fn as t) = do+        te <- asks envTyEnv+        (as',t') <- findArgsType te fn+        as'' <- mapM tcVal as+        if t' == t then+            if as'' == as' then return t' else+                tcErr $ "App: arguments do not match: " ++ show (a,as',t')+         else tcErr $ "App: results do not match: " ++ show (a,t,(as',t'))+    f e@(BaseOp (StoreNode _) vs) = do+        [NodeC {}] <- return vs+        mapM_ tcVal vs+        return (getType e)+    f Alloc { expValue = v, expCount = c, expRegion = r } = do+        t <- tcVal v+        tcVal c+        tcVal r+        return [TyPtr t]+    f (Return v) = mapM tcVal v+    f (BaseOp Promote [v]) = do+        TyINode <- tcVal v+        return [TyNode]+    f (BaseOp Demote [v]) = do+        TyNode <- tcVal v+        return [TyINode]+    f (Error _ t) = return t+    f e@(BaseOp Overwrite [w,v]) = do+        NodeC {} <- return v+        tcVal w+        tcVal v+        return []+    f e@(BaseOp PokeVal [w,v]) = do+        TyPtr t <- tcVal w+        tv <- tcVal v+        when (t /= tv) $+            tcErr "PokeVal: types don't match"+        return []+    f e@(BaseOp PeekVal [w]) = do+        TyPtr t <- tcVal w+        return [t]+    f (Case _ []) = tcErr "empty case"+    f (Case v as) = do+        tv <- tcVal v+        es <- mapM (tcLam (Just [tv])) as+        foldl1M (same $ "case exp: " ++ show (map head $ sortGroupUnder fst (zip es as)) ) es+    f (Let { expDefs = defs, expBody = body }) = do+        local (\e -> e { envTyEnv = extendTyEnv defs (envTyEnv e) }) $ do+            mapM_ (tcLam Nothing) [ b | FuncDef { funcDefBody = b } <- defs ]+            f body+    f _ = error "Grin.Lint: unknown value passed to f"++tcVal :: Val -> Tc Ty+tcVal v = f v where+    f e@(Var v t) = do+        s <- asks envInScope+        case v `member` s of+            True -> return t+            False -> tcErr $ "variable not in scope: " ++ show e+    f (Lit _ t) = return t+    f Unit = return TyUnit+    f (Const t) = do+        v <- f t+        case v of+            TyNode -> return TyINode+            v -> return (TyPtr v)+    f (Index v offset) = do+        t <- f v+        TyPrim _ <- f offset+        return t+    f (ValUnknown ty) = return ty+    f (ValPrim _ vs ty) = do mapM_ f vs >> return ty+    f n@(NodeC tg as) = do+        te <- asks envTyEnv+        (as',_) <- findArgsType te tg+        as'' <- mapM f as+        if as'' == as' then return TyNode else+            tcErr $ "NodeC: arguments do not match " ++ show n ++ show (as'',as')+    f (Item _ t) = return t
+ src/Grin/Main.hs view
@@ -0,0 +1,181 @@+module Grin.Main(compileToGrin) where++import Control.Monad+import Data.List+import Data.Monoid(mappend)+import System.Directory+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.UTF8 as LBS+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified System.FilePath as FP+import System.Exit++import C.Prims+import Grin.DeadCode+import Grin.Devolve(twiddleGrin,devolveTransform)+import Grin.EvalInline(createEvalApply)+import Grin.FromE+import Grin.Grin+import Grin.Lint+import Grin.NodeAnalyze+import Grin.Optimize+import Grin.SSimplify+import Grin.Show+import Grin.StorageAnalysis+import Ho.ReadSource+import Options+import PackedString+import RawFiles+import Support.TempDir+import Support.Transform+import Support.CompatMingw32+import Util.Gen+import qualified C.FromGrin2 as FG2+import qualified FlagDump as FD+import qualified Stats++{-# NOINLINE compileToGrin #-}+compileToGrin prog = do+    stats <- Stats.new+    putProgressLn "Converting to Grin..."+    x <- Grin.FromE.compile prog+    when verbose $ Stats.print "Grin" Stats.theStats+    wdump FD.GrinInitial $ do dumpGrin "initial" x+    x <- transformGrin simplifyParms x+    wdump FD.GrinNormalized $ do dumpGrin "normalized" x+    x <- explicitRecurse x+    lintCheckGrin x+    x <- transformGrin deadCodeParms x+    x <- transformGrin simplifyParms x+    x <- transformGrin pushParms x+    x <- transformGrin simplifyParms x+    putProgressLn "-- Speculative Execution Optimization"+    x <- grinSpeculate x+    lintCheckGrin x+    x <- transformGrin deadCodeParms x+    x <- transformGrin simplifyParms x+    x <- transformGrin pushParms x+    x <- transformGrin simplifyParms x+    wdump FD.OptimizationStats $ Stats.print "Optimization" stats+    putProgressLn "-- Node Usage Analysis"+    wdump FD.GrinPreeval $ dumpGrin "preeval" x+    x <- transformGrin nodeAnalyzeParms x+    x <- transformGrin simplifyParms x+    wdump FD.GrinPreeval $ dumpGrin "preeval2" x+    x <- transformGrin nodeAnalyzeParms x+    x <- transformGrin simplifyParms x+    x <- createEvalApply x+    x <- transformGrin simplifyParms x+    putProgressLn "-- Grin Devolution"+    wdump FD.GrinFinal $ dumpGrin "predevolve" x+    x <- transformGrin devolveTransform x+    --x <- opt "After Devolve Optimization" x+    x <- transformGrin simplifyParms x+    x <- return $ twiddleGrin x+ --   x <- return $ normalizeGrin x+--    x <- return $ twiddleGrin x+    x <- storeAnalyze x+    dumpFinalGrin x+    compileGrinToC x++dumpFinalGrin grin = do+    wdump FD.GrinGraph $ do+        let dot = graphGrin grin+        writeFile (outputName ++ "_grin.dot") dot+    wdump FD.GrinFinal $ dumpGrin "final" grin++compileGrinToC grin = do+    let (cg,Requires reqs) = FG2.compileGrin grin+        rls = filter ("-l" `isPrefixOf`) $ map (unpackPS . snd) (Set.toList reqs)+        fn = outputName ++ lup "executable_extension"+        lup k = maybe "" id $ Map.lookup k (optInis options)+    cf <- case (optOutName options,optStop options) of+            (Just fn,StopC) -> return fn+            _ | dump FD.C -> return (fn ++ "_code.c")+              | otherwise -> fileInTempDir ("main_code.c") (\_ -> return ())+    (argstring,sversion) <- getArgString+    (cc,args) <- fetchCompilerFlags+    forM_ [("rts/constants.h",constants_h),+           ("rts/stableptr.c",stableptr_c),+           ("rts/slub.c",slub_c),+           ("rts/profile.c",profile_c),+           ("rts/profile.h",profile_h),+           ("rts/gc.h",gc_h),+           ("rts/rts_support.c",rts_support_c),+           ("rts/rts_support.h",rts_support_h),+           ("rts/jhc_rts.c",jhc_rts_c),+           ("rts/jhc_rts.h",jhc_rts_h),+           ("lib/lib_cbits.c",lib_cbits_c),+           ("lib/lib_cbits.h",lib_cbits_h),+           ("rts/cdefs.h",cdefs_h),+           ("sys/queue.h",queue_h),+           ("HsFFI.h",hsffi_h),+           ("jhc_rts_header.h",jhc_rts_header_h),+           ("sys/wsize.h",wsize_h),+           ("rts/gc_jgc.c",gc_jgc_c),+           ("rts/gc_jgc.h",gc_jgc_h),+           ("rts/gc_jgc_internal.h",gc_jgc_internal_h),+           ("rts/gc_none.c",gc_none_c),+           ("rts/gc_none.h",gc_none_h),+           ("sys/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do+        fileInTempDir fn $ flip BS.writeFile bs+    let cFiles = ["rts/profile.c", "rts/rts_support.c", "rts/gc_none.c",+                  "rts/jhc_rts.c", "lib/lib_cbits.c", "rts/gc_jgc.c",+                  "rts/stableptr.c"]+    tdir <- getTempDir+    ds <- iocatch (getDirectoryContents (tdir FP.</> "cbits")) (\_ -> return [])+    let extraCFiles = map noEscapePath $ map (tdir FP.</>) cFiles ++ ["-I" ++ tdir ++ "/cbits", "-I" ++ tdir ] ++ [ tdir FP.</> "cbits" FP.</> fn | fn@(reverse -> 'c':'.':_) <- ds ]+    let comm = shellQuote $ [cc] ++ extraCFiles ++ [cf, "-o", fn] ++ args ++ rls+        globalvar n c = LBS.fromString $ "char " ++ n ++ "[] = \"" ++ c ++ "\";"+    putProgressLn ("Writing " ++ show cf)+    LBS.writeFile cf $ LBS.intercalate (LBS.fromString "\n") [+        globalvar "jhc_c_compile" comm, globalvar "jhc_command" argstring,+        globalvar "jhc_version" sversion,LBS.empty,cg]+    when (optStop options == StopC) $+        exitSuccess+    putProgressLn ("Running: " ++ comm)+    r <- systemCompat comm+    when (r /= ExitSuccess) $ fail "C code did not compile."+    return ()++grinParms = transformParms {+    transformDumpProgress = verbose,+    transformPass = "Grin"+    }++simplifyParms = grinParms {+    transformCategory = "Simplify",+    transformOperation = Grin.SSimplify.simplify,+    transformIterate = IterateDone+    }++nodeAnalyzeParms = grinParms {+    transformCategory = "NodeAnalyze",+    transformOperation = nodealyze+    } where+        nodealyze grin = do+            stats <- Stats.new+            g <- deadCode stats (grinEntryPointNames grin) grin+            g <- nodeAnalyze g+            st <- Stats.readStat stats+            return g { grinStats = grinStats grin `mappend` st }++pushParms = grinParms {+    transformCategory = "Push",+    transformOperation = pushGrin+    } where+        pushGrin grin = do+            nf   <- mapMsnd (grinPush undefined) (grinFuncs grin)+            return $ setGrinFunctions nf grin++deadCodeParms = grinParms {+    transformCategory = "DeadCode",+    transformOperation = op+    } where+        op grin = do+            stats <- Stats.new+            g <- deadCode stats (grinEntryPointNames grin) grin+            st <- Stats.readStat stats+            return g { grinStats = grinStats grin `mappend` st }
+ src/Grin/NodeAnalyze.hs view
@@ -0,0 +1,444 @@+-- a fast, straightforward points to analysis+-- meant to determine nodes that are always in whnf+-- and find out evals or applys that always+-- apply to a known value++module Grin.NodeAnalyze(nodeAnalyze) where++import Control.Monad.Identity hiding(join)+import Control.Monad.RWS hiding(join)+import Data.Maybe+import Text.Printf+import qualified Data.Map as Map+import qualified Data.Set as Set++import Grin.Grin hiding(V)+import Grin.Noodle+import Options+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Support.Tickle+import Util.Gen+import Util.SetLike+import Util.UnionSolve+import Util.UniqueMonad+import qualified Stats++data NodeType+    = WHNF       -- ^ guarenteed to be a WHNF+    | Lazy       -- ^ a suspension, a WHNF, or an indirection to a WHNF+    deriving(Eq,Ord,Show)++data N = N !NodeType (Topped (Set.Set Atom))+    deriving(Eq)++instance Show N where+    show (N nt ts) = show nt ++ "-" ++ f ts  where+        f Top = "[?]"+        f (Only x) = show (Set.toList x)++instance Fixable NodeType where+    isBottom x = x == WHNF+    isTop x = x == Lazy+    join x y = max x y+    meet x y = min x y+    eq = (==)+    lte x y = x <= y++instance Fixable N where+    isBottom (N a b) = isBottom a && isBottom b+    isTop (N a b) = isTop a && isTop b+    join  (N x y) (N x' y') = N (join x x') (join y y')+    meet  (N x y) (N x' y') = N (meet x x') (meet y y')+    lte   (N x y) (N x' y') = lte x x' && lte y y'+    eq    (N x y) (N x' y') = eq x x' && eq y y'+    showFixable n = show n++data V = V Va Ty | VIgnore+    deriving(Eq,Ord)++data Va =+    Vr !Var+    | Fa !Atom !Int+    | Fr !Atom !Int+    deriving(Eq,Ord)++vr v t = V (Vr v) t+fa n i t = V (Fa n i) t+fr n i t = V (Fr n i) t++class NodeLike a where+    isGood :: a -> Bool++instance NodeLike Ty where+    isGood TyNode = True+    isGood TyINode = True+    isGood _ = False++instance NodeLike Val where+    isGood v = isGood (getType v)++instance NodeLike V where+    isGood (V _ t) = isGood t+    isGood _ = False++instance NodeLike (Either V b) where+    isGood (Left n) = isGood n+    isGood _ = True++instance Show V where+    showsPrec _ (V (Vr v) ty) = shows (Var v ty)+    showsPrec _ (V (Fa a i) _) = shows (a,i)+    showsPrec _ (V (Fr a i) _) = shows (i,a)+    showsPrec _ VIgnore = showString "IGN"++newtype M a = M (RWS TyEnv (C N V) Int a)+    deriving(Monad,Functor,MonadWriter (C N V))++runM :: Grin -> M a -> C N V+runM grin (M w) = case runRWS w (grinTypeEnv grin) 1 of+    (_,_,w) -> w++{-# NOINLINE nodeAnalyze #-}+nodeAnalyze :: Grin -> IO Grin+nodeAnalyze grin' = do+    let cs = runM grin $ do+            mapM_ doFunc (grinFuncs grin)+            mapM_ docaf (grinCafs grin)+            doFunc (toAtom "@initcafs",[] :-> initCafs grin)+        grin = renameUniqueGrin grin'+        docaf (v,tt) | True = tell $ Right top `equals` Left (V (Vr v) TyINode)+                     | otherwise = return ()+    --putStrLn "----------------------------"+    --print cs+    --putStrLn "----------------------------"+    --putStrLn "-- NodeAnalyze"+    (rm,res) <- solve (const (return ())) cs+    --(rm,res) <- solve putStrLn cs+    --putStrLn "----------------------------"+    --mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList rm)+    --putStrLn "----------------------------"+    --mapM_ print (Map.elems res)+    --putStrLn "----------------------------"+    let cmap = Map.map (fromJust . flip Map.lookup res) rm+    (grin',stats) <- Stats.runStatT $ tickleM (fixupfs cmap (grinTypeEnv grin)) grin+    return $ transformFuncs (fixupFuncs (grinSuspFunctions grin) (grinPartFunctions grin) cmap) grin' { grinStats = stats `mappend` grinStats grin' }++data Todo = Todo !Bool [V] | TodoNothing++initCafs grin = f (grinCafs grin) (Return []) where+        f ((v,node):rs) rest = BaseOp Overwrite [(Var v TyINode),node] :>>= [] :-> f rs rest+        f [] rest = rest++doFunc :: (Atom,Lam) -> M ()+doFunc (name,arg :-> body) = ans where+    ans :: M ()+    ans = do+        let rts = getType body+        forMn_ rts $ \ (t,i) -> dVar (fr name i t) t+        forMn_ arg $ \ (~(Var v vt),i) -> do+            dVar (vr v vt) vt+            tell $ cAnnotate "FunArg" $ Left (fa name i vt) `equals` Left (vr v vt)+        fn (Todo True [ fr name i t | i <- naturals | t <- rts ]) body+    -- restrict values of TyNode type to be in WHNF+    dVar v TyNode = do+        tell $ Left v `islte` Right (N WHNF Top)+    dVar _ _ = return ()+    -- set concrete values for vars based on their type only+    -- should only be used in patterns+    zVar s v TyNode = tell $ cAnnotate ("zVar - tynode " ++ s) $ Left (vr v TyNode) `equals` Right (N WHNF Top)+    zVar s v t = tell $ cAnnotate ("zVar - inode " ++ s) $ Left (vr v t) `equals` Right top+    fn :: Todo -> Exp -> M ()+    fn ret body = f body where+        f (x :>>= [Var v vt] :-> rest) = do+            dVar (vr v vt) vt+            gn (Todo True [vr v vt]) x+            f rest+        f (x :>>= vs@(_:_:_) :-> rest) = do+            vs' <- forM vs $ \ (Var v vt) -> do+                dVar (vr v vt) vt+                return $ vr v vt+            gn (if all (== VIgnore) vs' then TodoNothing else Todo True vs') x+            f rest+        f (x :>>= v :-> rest) = do+            forM_ (Set.toList $ freeVars v) $ \ (v,vt) -> zVar "Bind" v vt+            gn TodoNothing x+            f rest+        f body = gn ret body+    isfn _ x y | not (isGood x) = mempty+    isfn (Todo True  _) x y = cAnnotate "isfn True" $ Left x `equals` y+    isfn (Todo False _) x y = cAnnotate "isfn False" $ Left x `isgte` y+    --isfn (Todo _ _) x y = Left x `isgte` y+    isfn TodoNothing x y =  mempty+    equals x y | isGood x && isGood y = Util.UnionSolve.equals x y+               | otherwise = mempty+    isgte x y | isGood x && isGood y = Util.UnionSolve.isgte x y+              | otherwise = mempty+    islte x y | isGood x && isGood y = Util.UnionSolve.islte x y+              | otherwise = mempty+    gn ret head = f head where+        fl ret (v :-> body) = do+            forM_ (Set.toList $ freeVars v) $ \ (v,vt) -> zVar "Alt" v vt+            fn ret body+        dunno ty = do+            dres [Right (if TyNode == t then N WHNF Top else top) | t <- ty ]+        dres res = do+            case ret of+                Todo b vs | length res /= length vs -> error "lengths don't match!"+                Todo b vs -> forM_ (zip vs res) $ \ (v,r) -> tell (isfn ret v r)+                _ -> return ()+        f (_ :>>= _) = error $ "Grin.NodeAnalyze: :>>="+        f (Case v as)+            | Todo _ n <- ret = mapM_ (fl (Todo False n)) as+            | TodoNothing <- ret = mapM_ (fl TodoNothing) as+        f (BaseOp Eval [x]) = do+            dres [Right (N WHNF Top)]+        f (BaseOp (Apply ty) xs) = do+            mapM_ convertVal xs+            dunno ty+        f (App { expFunction = fn, expArgs = vs, expType = ty }) = do+            vs' <- mapM convertVal vs+            forMn_ (zip vs vs') $ \ ((tv,v),i) -> do+                tell $ v `islte` Left (fa fn i (getType tv))+            dres [Left $ fr fn i t | i <- [ 0 .. ] | t <- ty ]+        f (Call { expValue = Item fn _, expArgs = vs, expType = ty }) = do+            vs' <- mapM convertVal vs+            forMn_ (zip vs vs') $ \ ((tv,v),i) ->  do+                tell $ v `islte` Left (fa fn i (getType tv))+            dres [Left $ fr fn i t | i <- [ 0 .. ] | t <- ty ]+        f (Return x) = do mapM convertVal x >>= dres+        f (BaseOp (StoreNode _) w) = do mapM convertVal w >>= dres+        f (BaseOp Promote [w]) = do+            ww <- convertVal w+            tell $ ww `islte` Right (N WHNF Top)+            dres [ww]+        f (BaseOp Demote [w]) = do+            ww <- convertVal w+            tell $ ww `islte` Right (N WHNF Top)+            dres [ww]+        f Error {} = return ()+        f Prim { expArgs = as, expType = ty } = mapM_ convertVal as >> dunno ty+        f Alloc { expValue = v } | getType v == TyNode = do+            v' <- convertVal v+            dres [v']+        f Alloc { expValue = v } | getType v == tyINode = do+            convertVal v+            dunno [TyPtr tyINode]+        f NewRegion { expLam = _ :-> body } = fn ret body+        f (BaseOp Overwrite [Var vname ty,v]) | ty == TyINode = do+            v' <- convertVal v+            tell $ Left (vr vname ty) `isgte` v'+            dres []+        f e@(BaseOp Overwrite vs) = do mapM_ convertVal vs >> dunno (getType e)+        f e@(BaseOp PokeVal vs) = do mapM_ convertVal vs >> dunno (getType e)+        f e@(BaseOp PeekVal vs) = do mapM_ convertVal vs  >> dunno (getType e)+        f Let { expDefs = ds, expBody = e } = do+            mapM_ doFunc (map (\x -> (funcDefName x, funcDefBody x)) ds)+            fn ret e+        f exp = error $ "NodeAnalyze.f: " ++ show exp++    convertVal (Const n@(NodeC _ _)) = convertVal n+    convertVal (Const _) = return $ Right (N WHNF Top)+    convertVal (NodeC t vs) = case tagUnfunction t of+        Nothing -> do+            mapM_ convertVal vs+            return $ Right (N WHNF (Only $ Set.singleton t))+        Just (n,fn) -> do+            vs' <- mapM convertVal vs+            forMn_ (zip vs vs') $ \ ((vt,v),i) -> do+                tell $ v `islte` Left (fa fn i (getType vt))+            forM_ [0 .. n - 1 ] $ \i -> do+               tell $ Right top `islte` Left (fa fn (length vs + i) TyINode)+            return $ Right (N (if n == 0 then Lazy else WHNF) (Only $ Set.singleton t))+    convertVal (Var v t) = return $ Left (vr v t)+    convertVal v | isGood v = return $ Right (N Lazy Top)+    convertVal Lit {} = return $ Left VIgnore+    convertVal ValPrim {} = return $ Left VIgnore+    convertVal Index {} = return $ Left VIgnore+    convertVal Item {} = return $ Left VIgnore+    convertVal ValUnknown {} = return $ Left VIgnore+    convertVal v = error $ "convertVal " ++ show v++bottom = N WHNF (Only (Set.empty))+top = N Lazy Top++data WhatToDo+    = WhatDelete+    | WhatUnchanged+    | WhatConstant Val+    | WhatSubs Ty (Val -> Exp) (Val -> Exp)++--isWhatUnchanged WhatUnchanged = True+--isWhatUnchanged _ = False++transformFuncs :: (Atom -> [Ty] -> Maybe [Ty] -> (Maybe [WhatToDo],Maybe [WhatToDo])) -> Grin -> Grin+transformFuncs fn grin = grin'' where+    grin'' =  grin' { grinTypeEnv = extendTyEnv (grinFunctions grin') (grinTypeEnv grin') }+    grin' = setGrinFunctions (nfs $ grinFuncs grin) grin+    nfs ds = map fs ds+    fs (n,l@(ps :-> e)) = (n,f (fn n (map getType ps) (Just $ getType e)) l)+    f (Nothing,Nothing) (p :-> e) = p :-> j e+    f (Just ats,rts') (p :-> e) = p' :-> e' where+        rts = maybe (map (const WhatUnchanged) (getType e)) id rts'+        p' = concatMap f (zip p ats) where+            f (v,WhatUnchanged) = [v]+            f (_,WhatDelete) = []+            f (_,WhatConstant _) = []+            f (Var v _,WhatSubs nty _ _) = [Var v nty]+            f _ = error "NodeAnalyze.transformFuncs: f bad."+        e' =  g (zip p ats) (j e)+        g ((_,WhatUnchanged):xs) e = g xs e+        g ((_,WhatDelete):xs) e = g xs e+        g ((vr,WhatConstant c):xs) e = Return [c] :>>= [vr] :-> g xs e+        g ((Var v vt,WhatSubs nt _ ft):xs) e = ft (Var v nt) :>>= [Var v vt] :-> g xs e+        g [] e = e :>>= rvs :-> h (zip rvs rts) (drop (length (getType e)) [v1 .. ]) [] where+            rvs = zipWith Var [v1 .. ] (getType e)+        g _ _ = error "NodeAnalyze.transformFuncs: g bad."+        h ((r,WhatUnchanged):xs) vs rs = h xs vs (r:rs)+        h ((r,WhatDelete):xs) vs rs = h xs vs rs+        h ((r,WhatConstant _):xs) vs rs = h xs vs rs+        h ((r,WhatSubs nty tt _):xs) (v:vs) rs = tt r :>>= [Var v nty] :-> h xs vs (Var v nty:rs)+        h [] _ rs = Return (reverse rs)+        h _ _ _ = error "NodeAnalyze.transformFuncs: h bad."+    f _ _ = error "NodeAnalyze.transformFuncs: f bad."++    j app@(BaseOp (StoreNode False) [NodeC a xs]) = res where+        res = if isNothing ats' then app else e'+        ats = maybe (repeat WhatUnchanged) id ats'+        (ats',_) = fn (tagFlipFunction a) (map getType xs) Nothing+        lvars = zipWith Var [ v1 .. ] (map getType xs)+        e' = Return xs :>>= lvars :-> f (zip lvars ats) []++        f ((v,WhatUnchanged):xs) rs = f xs (v:rs)+        f ((_,WhatDelete):xs) rs = f xs rs+        f ((_,WhatConstant _):xs) rs = f xs rs+        f ((Var v oty,WhatSubs nty tt _):xs) rs = tt (Var v oty) :>>= [Var v nty] :-> f xs (Var v nty:rs)+        f [] rs = BaseOp (StoreNode False) [NodeC a (reverse rs)]+        f _ _ = error "NodeAnalyze.transformFuncs: f bad."++    j app@(App a xs ts) = res where+        res = if isNothing ats' && isNothing rts'  then app else e'+        ats = maybe (repeat WhatUnchanged) id ats'+        rts = maybe (repeat WhatUnchanged) id rts'+        (ats',rts') = fn a (map getType xs) (Just ts)+        lvars = zipWith Var [ v1 .. ] (map getType xs)+        e' = Return xs :>>= lvars :-> f (zip lvars ats) []++        f ((v,WhatUnchanged):xs) rs = f xs (v:rs)+        f ((_,WhatDelete):xs) rs = f xs rs+        f ((_,WhatConstant _):xs) rs = f xs rs+        f ((Var v oty,WhatSubs nty tt _):xs) rs = tt (Var v oty) :>>= [Var v nty] :-> f xs (Var v nty:rs)+        f [] rs = App a (reverse rs) ts' :>>= rvars :-> g (zip rvars' rts) rvars []+        f _ _ = error "NodeAnalyze.transformFuncs: f bad."++        g [] [] rs = Return (reverse rs)+        g ((_,WhatUnchanged):xs) (n:ns) rs = g xs ns (n:rs)+        g ((v,WhatDelete):xs) vs rs = Return [ValUnknown (getType v)] :>>= [v] :-> g xs vs (v:rs)+        g ((v,WhatConstant c):xs) vs rs = Return [c] :>>= [v] :-> g xs vs (v:rs)+        g ((v,WhatSubs _ _ ft):xs) (n:ns) rs = ft n :>>= [v] :-> g xs ns (v:rs)+        g _ _ _ = error "NodeAnalyze.transformFuncs: g bad."++        rvars = zipWith Var [ v1 .. ] ts'+        rvars' = zipWith Var (drop (length rvars) [ v1 .. ]) ts+        ts' = concatMap g (zip ts rts) where+            g (t,WhatUnchanged) = [t]+            g (t,WhatConstant _) = []+            g (t,WhatDelete) = []+            g (t,WhatSubs nty _ _) = [nty]++    j Let { expDefs = ds, expBody = e } =  grinLet [ updateFuncDefProps d { funcDefBody = snd $ fs (funcDefName d, funcDefBody d) } | d <- ds ] (j e)+    j e = runIdentity $ mapExpExp (return . j) e++fixupFuncs sfuncs pfuncs cmap  = ans where+    ans a as jrs | a `Set.member` pfuncs = (Nothing,Nothing)+                 | a `Set.member` sfuncs = (Just aargs,Nothing)+                 | otherwise =  (Just aargs,fmap rargs jrs) where+        aargs = map (bool pnode WhatUnchanged) largs+        largs = map (lupArg fa a) (zip as [0 ..  ])+        rargs rs = map (bool pnode WhatUnchanged) (map (lupArg fr a) (zip rs [0 ..  ]))+    lupArg fa a (x,i) =  case (x,Map.lookup (fa a i x) cmap) of+        (TyINode,Just (ResultJust _ (N WHNF _))) -> True+        (TyINode,Just ResultBounded { resultLB = Just (N WHNF _) }) -> True+        (TyINode,Just ResultBounded { resultLB = Nothing }) -> True+        _ -> False+    pnode = WhatSubs TyNode (\v -> BaseOp Promote [v]) (\v -> BaseOp Demote [v])++fixupfs cmap tyEnv l = tickleM f (l::Lam) where+    lupVar (Var v t) =  case Map.lookup (vr v t) cmap of+        _ | v < v0 -> fail "nocafyet"+        Just (ResultJust _ lb) -> return lb+        Just ResultBounded { resultLB = Just lb } -> return lb+        Just ResultBounded { resultLB = Nothing } -> return bottom+        _ -> fail "lupVar"+    lupVar _ = fail "lupVar2"+    pstuff x arg n@(N w t) = liftIO $ when verbose (printf "-- %s %s %s\n" x (show arg) (show n))+    f a@(BaseOp Eval [arg]) | Just n <- lupVar arg = case n of+        N WHNF _ -> do+            pstuff "eval" arg n+            Stats.mtick (toAtom "Optimize.NodeAnalyze.eval-promote")+            return (BaseOp Promote [arg])+        _ -> return a+    f a@(BaseOp (Apply ty) (papp:args)) | Just nn <- lupVar papp = case nn of+        N WHNF tset | Only set <- tset, [sv] <- Set.toList set, TagPApp n fn <- tagInfo sv, Just (ts,_) <- findArgsType tyEnv sv -> do+            pstuff "apply" papp nn+            case (n,args) of+                (1,[arg]) -> do+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")+                    let va = Var v1 (getType arg)+                        vars = zipWith Var [ v2 .. ] ts+                    return $ Return [arg,papp] :>>= [va,NodeC sv vars] :-> App fn (vars ++ [va]) ty+                (1,[]) -> do+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")+                    let vars = zipWith Var [ v2 .. ] ts+                    return $ Return [papp] :>>= [NodeC sv vars] :-> App fn vars ty+                (pn,[arg]) -> do+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")+                    let va = Var v1 (getType arg)+                        vars = zipWith Var [ v2 .. ] ts+                    return $ Return [arg,papp] :>>= [va,NodeC sv vars] :-> dstore (NodeC (partialTag fn (pn - 1)) (vars ++ [va]))+                (pn,[]) -> do+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")+                    let vars = zipWith Var [ v2 .. ] ts+                    return $ Return [papp] :>>= [NodeC sv vars] :-> dstore (NodeC (partialTag fn (pn - 1)) vars)+                _ -> return a+        _ -> return a+    f e = mapExpExp f e++dstore x = BaseOp (StoreNode True) [x]++renameUniqueGrin :: Grin -> Grin+renameUniqueGrin grin = res where+    (res,()) = evalRWS (execUniqT 1 ans) ( mempty :: Map.Map Atom Atom) (fromList [ x | (x,_) <- grinFuncs grin ] :: Set.Set Atom)+    ans = do tickleM f grin+    f (l :-> b) = g b >>= return . (l :->)+    g a@App  { expFunction = fn } = do+        m <- lift ask+        case mlookup fn m of+            Just fn' -> return a { expFunction = fn' }+            _ -> return a+    g a@Call { expValue = Item fn t } = do+        m <- lift ask+        case mlookup fn m of+            Just fn' -> return a { expValue = Item fn' t }+            _ -> return a+    g (e@Let { expDefs = defs }) = do+        (defs',rs) <- liftM unzip $ flip mapM defs $ \d -> do+            (nn,rs) <- newName (funcDefName d)+            return (d { funcDefName = nn },rs)+        local (fromList rs `mappend`) $  mapExpExp g e { expDefs = defs' }+    g b = mapExpExp g b+    newName a = do+        m <- lift get+        case member a m of+            False -> do lift $ modify (insert a); return (a,(a,a))+            True -> do+            let cfname = do+                uniq <- newUniq+                let fname = toAtom $ show a  ++ "-" ++ show uniq+                if fname `member` (m :: Set.Set Atom) then cfname else return fname+            nn <- cfname+            lift $ modify (insert nn)+            return (nn,(a,nn))++bool x y b = if b then x else y
+ src/Grin/Noodle.hs view
@@ -0,0 +1,259 @@+module Grin.Noodle where++-- various routines for manipulating and exploring grin code.++import Control.Monad.Writer+import qualified Data.Set as Set++import C.Prims+import Debug.Trace+import Grin.Grin+import Options(flint)+import StringTable.Atom(Atom())+import Support.CanType+import Support.FreeVars+import Support.Tickle+import Util.GMap+import Util.Gen+import Util.HasSize+import Util.SetLike++modifyTail :: Lam -> Exp -> Exp+modifyTail lam@(_ :-> lb) te = f (sempty :: GSet Atom) te where+    lamFV = freeVars lam :: GSet Var+    f lf e | False && trace ("modifyTail: " ++ show (lf,e)) False = undefined+    f _ (Error s ty) = Error s (getType lb)+    f lf (Case x ls) = Case x (map (g lf) ls)+    f _ lt@Let {expIsNormal = False } = lt :>>= lam+    f lf lt@Let {expDefs = defs, expBody = body, expIsNormal = True } = updateLetProps lt { expBody = f nlf body, expDefs = defs' } where+        nlf = lf `union` fromList (map funcDefName defs)+        defs' = [ updateFuncDefProps d { funcDefBody = g nlf (funcDefBody d) } | d <- defs ]+    f lf lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lf lam, expCont = g lf cont }+    f lf (e1 :>>= p :-> e2) = e1 :>>= p :-> f lf e2+    f lf e@(App a as t) | a `member` lf = App a as (getType lb)+    f lf e = e :>>= lam+    g lf (p :-> e) | flint && not (isEmpty $ intersection (freeVars p) lamFV) = error "modifyTail: lam floated inside bad scope"+    g lf (p :-> e) = p :-> f lf e++instance Tickleable Exp Lam where+    tickleM = mapBodyM+instance Tickleable Exp Exp where+    tickleM = mapExpExp+instance Tickleable Val Exp where+    tickleM = mapExpVal+instance Tickleable Val Val where+    tickleM = mapValVal+    tickleM_ = mapValVal_+instance Tickleable Lam Grin where+    tickleM f grin = liftM (`setGrinFunctions` grin) $ mapM  (\x -> do nb <- f (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin)+instance Tickleable Lam FuncDef where+    tickleM f fd = funcDefBody_uM f fd+instance Tickleable (Atom,Lam) FuncDef where+    tickleM f fd@FuncDef { funcDefName = n, funcDefBody = b } = do+    (n',b') <- f (n,b)+    return $  updateFuncDefProps fd { funcDefBody = b', funcDefName = n' }++mapBodyM :: Monad m => (Exp -> m Exp) -> Lam -> m Lam+mapBodyM f (x :-> y) = f y >>= return . (x :->)++mapExpVal :: Monad m => (Val -> m Val) -> Exp -> m Exp+mapExpVal g x = f x where+    f (App a vs t) = return (App a) `ap` mapM g vs `ap` return t+    f (BaseOp a vs) = return (BaseOp a) `ap` mapM g vs+    f (Return vs) = return Return `ap` mapM g vs+    f (Prim x vs t) = return (Prim x) `ap` mapM g vs `ap` return t+    f e@Alloc { expValue = v, expCount = c } = do+        v <- g v+        c <- g c+        return e { expValue = v, expCount = c }+    f (Case v as) = do+        v <- g v+        return (Case v as)+    f e = return e++mapValVal fn x = f x where+    f (NodeC t vs) = return (NodeC t) `ap` mapM fn vs+    f (Index a b) = return Index `ap` fn a `ap` fn b+    f (Const v) = return Const `ap` fn v+    f (ValPrim p vs ty) = return (ValPrim p) `ap` mapM fn vs `ap` return ty+    f x = return x++mapValVal_ fn x = f x where+    f (NodeC t vs) = mapM_ fn vs+    f (Index a b) = fn a >> fn b >> return ()+    f (Const v) = fn v >> return ()+    f (ValPrim p vs ty) =  mapM_ fn vs >> return ()+    f _ = return ()++mapExpLam fn e = f e where+    f (a :>>= b) = return (a :>>=) `ap` fn b+    f (Case e as) = return (Case e) `ap` mapM fn as+    f lt@Let { expDefs = defs } = do+        defs' <- forM defs $ \d -> do+            b <- fn $ funcDefBody d+            return $ updateFuncDefProps d { funcDefBody = b }+        return $ updateLetProps lt { expDefs = defs' }+    f nr@NewRegion { expLam = lam } = do+        lam <- fn lam+        return $ nr { expLam = lam }+    f e@MkCont { expCont = c, expLam = l } = do+        c <- fn c+        l <- fn l+        return $ e { expCont = c, expLam = l }+    f e = return e++mapExpExp fn e = f e where+    f (a :>>= b) = return (:>>=) `ap` fn a `ap` g b+    f l@Let { expBody = b, expDefs = defs } = do+        b <- fn b+        return updateLetProps `ap` (mapExpLam g l { expBody = b })+    f (GcRoots vs e) = return (GcRoots vs) `ap` fn e+    f e = mapExpLam g e+    g (l :-> e) = return (l :->) `ap` fn e++mapFBodies f xs = mapM f' xs where+    f' fd@FuncDef { funcDefBody = l :-> r } = do+        r' <- f r+        return $  updateFuncDefProps fd { funcDefBody = l :-> r' }++funcDefBody_uM f fd@FuncDef { funcDefBody = b } = do+    b' <- f b+    return $  updateFuncDefProps fd { funcDefBody = b' }++grinFunctions_s nf grin = grin { grinFunctions = nf }++--------------------------+-- examining and reporting+--------------------------++isManifestNode :: Monad m => Exp -> m [Atom]+isManifestNode e = f (sempty :: GSet Atom) e where+    f lf _ | False && trace ("isManifestNode: " ++ show lf) False = undefined+    f lf (Return [(NodeC t _)]) = return [t]+    f lf Error {} = return []+    f lf (App a _ _) | a `member` lf = return []+    f lf Let { expBody = body, expIsNormal = False } = f lf body+    f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where+        nlf = lf `union` fromList (map funcDefName defs)+        ans = do+            xs <- mapM (f nlf . lamExp . funcDefBody) defs+            b <- f nlf body+            return (concat (b:xs))+    f lf (Case _ ls) = do+        cs <- Prelude.mapM (f lf) [ e | _ :-> e <- ls ]+        return $ concat cs+    f lf (_ :>>= _ :-> e) = isManifestNode e+    f lf _ = fail "not manifest node"++-- | Is a Val constant?+valIsConstant :: Val -> Bool+valIsConstant (NodeC _ xs) = all valIsConstant xs+valIsConstant Lit {} = True+valIsConstant Const {} = True+valIsConstant (Var v _) | v < v0 = True+valIsConstant (Index v t) = valIsConstant v && valIsConstant t+valIsConstant ValPrim {} = True+valIsConstant _ = False++-- NOPs will not produce any code at run-time so we can tail-call through them.+isNop (BaseOp Promote _) = True+isNop (BaseOp Demote _) = True+isNop _ = False++isOmittable (BaseOp Promote _) = True+isOmittable (BaseOp Demote _) = True+isOmittable (BaseOp PeekVal _) = True+isOmittable (BaseOp ReadRegister _) = True+isOmittable (BaseOp NewRegister _) = True+isOmittable (BaseOp GcPush _) = True  -- omittable because if we don't use the returned gc context, then we don't need to push to begin with+isOmittable (BaseOp (StoreNode _) _) = True+isOmittable Alloc {} = True+isOmittable (Return {}) = True+isOmittable Prim { expPrimitive = aprim } = primIsCheap aprim+isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]+isOmittable Let { expBody = x } = isOmittable x+isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2+isOmittable _ = False++isErrOmittable (BaseOp Overwrite _) = True+isErrOmittable (BaseOp PokeVal _) = True+isErrOmittable (BaseOp WriteRegister _) = True+isErrOmittable (e1 :>>= _ :-> e2) = isErrOmittable e1 && isErrOmittable e2+isErrOmittable (Case x ds) = all isErrOmittable [ e | _ :-> e <- ds ]+isErrOmittable x = isOmittable x++-- collect tail and normally called functions+-- expression (tail called, non tail called)+collectFuncs :: Exp -> (Set.Set Atom,Set.Set Atom)+collectFuncs exp = runWriter (cfunc exp) where+        clfunc (l :-> r) = cfunc r+        cfunc e | False && trace ("isManifestNode: " ++ show e) False = undefined+        cfunc (e :>>= v :-> op@(BaseOp _ v')) | isNop op && v == v' = do cfunc e+        cfunc (e :>>= y) = do+            xs <- cfunc e+            tell xs+            clfunc y+        cfunc (App a _ _) = return (singleton a)+        cfunc (Case _ as) = do+            rs <- mapM clfunc as+            return (mconcat rs)+        cfunc Let { expFuncCalls = (tail,nonTail) } = do+            tell nonTail+            return tail+        cfunc Error {} = return mempty+        cfunc Prim {} = return mempty+        cfunc Return {} = return mempty+        cfunc BaseOp {} = return mempty+        cfunc Alloc {} = return mempty+        cfunc GcRoots { expBody = b} = cfunc b+        cfunc NewRegion { expLam = l } = clfunc l+        cfunc MkCont { expCont = l1, expLam = l2 } = do+            a <- clfunc l1+            b <- clfunc l2+            return (a `mappend` b)+        cfunc x = error "Grin.Noodle.collectFuncs: unknown"++grinLet defs body = updateLetProps Let {+    expDefs = defs,+    expBody = body,+    expInfo = mempty,+    expNonNormal = undefined,+    expIsNormal = undefined,+    expFuncCalls = undefined }++updateLetProps Let { expDefs = [], expBody = body } = body+updateLetProps lt@Let { expBody = body, expDefs = defs } =+        lt {+            expFuncCalls = (tail \\ myDefs, nonTail \\ myDefs),+            expNonNormal = notNormal,+            expIsNormal = isEmpty notNormal+            } where+    (tail,nonTail) = mconcatMap collectFuncs (body : map (lamExp . funcDefBody) defs)+    notNormal =  nonTail `intersection` (fromList $ map funcDefName defs)+    myDefs = fromList $ map funcDefName defs+updateLetProps e = e++data ReturnInfo = ReturnNode (Maybe Atom,[Ty]) | ReturnConst Val | ReturnCalls Atom | ReturnOther | ReturnError+    deriving(Eq,Ord)++getReturnInfo :: Exp -> [ReturnInfo]+getReturnInfo  e = ans where+    ans = execWriter (f (sempty :: GSet Atom) e)+    tells x = tell [x]+    f lf (Return [(NodeC t as)]) = tells (ReturnNode (Just t,map getType as))+    f lf (Return [z]) | valIsConstant z = tell [ReturnConst z]+    f lf Error {} = tells ReturnError+    f lf (Case _ ls) = do Prelude.mapM_ (f lf) [ e | _ :-> e <- ls ]+    f lf (_ :>>= _ :-> e) = f lf e+    f lf Let { expBody = body, expIsNormal = False } = f lf body+    f lf (App a _ _) | a `member` lf = return ()+    f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where+        nlf = lf `union` fromList (map funcDefName defs)+        ans = do+            mapM_ (f nlf . lamExp . funcDefBody) defs+            f nlf body+    f _ (App a _ _) = tells $ ReturnCalls a+    f _ e = tells ReturnOther++mapGrinFuncsM :: Monad m => (Atom -> Lam -> m Lam) -> Grin -> m Grin+mapGrinFuncsM f grin = liftM (`setGrinFunctions` grin) $ mapM  (\x -> do nb <- f (funcDefName x) (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin)
+ src/Grin/Optimize.hs view
@@ -0,0 +1,204 @@+module Grin.Optimize(grinPush,grinSpeculate) where++import Control.Monad.State+import Data.List+import qualified Data.Set as Set++import C.Prims+import Grin.Grin+import Grin.Noodle+import Options (verbose)+import Stats hiding(null,isEmpty)+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.GMap+import Util.Graph+import Util.HasSize+import Util.SetLike++data PExp = PExp {+    pexpUniq :: Int,+    pexpBind :: [Val],+    pexpExp  :: Exp,+    pexpProvides :: [Var],+    pexpDeps :: [Int]+    } deriving(Show)++instance Eq PExp where+    a == b = pexpUniq a == pexpUniq b++makeDeps :: [PExp] -> PExp -> PExp+makeDeps cs pexp = pexp { pexpProvides = freeVars (pexpBind pexp), pexpDeps = deps } where+    deps = [ pexpUniq c | c <- cs, not $ null $ fvs `intersect` pexpProvides c ]+    fvs = freeVars (pexpExp pexp)++justDeps :: [PExp] -> [Var] -> [Int]+justDeps cs fs = deps where+    deps = [ pexpUniq c | c <- cs, not $ null $ fs `intersect` pexpProvides c ]++-- | grinPush pushes the definitions of variables as far inward as they can go so+-- peephole optimizations have a better chance of firing. when the order of definitons+-- doesn't matter, it uses heuristics to decide which one to push to allow the most+-- peephole optimizations.++grinPush :: Stats -> Lam -> IO Lam+grinPush stats (l :-> e) = ans where+    ans = do+--        putStrLn "@@@ grinPush"+        e' <- evalStateT (f e) (1,[])+        return (l :-> e')+    f (exp :>>= v :-> e2) | isOmittable exp = do+        (nn,cv) <- get+        let npexp = makeDeps cv PExp { pexpUniq = nn, pexpBind = v, pexpExp = exp, pexpDeps = undefined, pexpProvides = undefined }+        put (nn+1,npexp:cv)+        f e2+    f (exp :>>= v :-> e2) = do+        exp <- fixupLet exp+        (v',exp') <- dropAny (Just v) exp+        e2' <- f e2+        return $ exp' :>>= v' :-> e2'+    f exp = do+        exp <- fixupLet exp+        (_,exp') <- dropAny Nothing exp+        return exp'++    fixupLet lt@Let { expDefs = defs, expBody = b } = do+        let def = (fromList $ map funcDefName defs :: GSet Atom)+            f (e :>>= l :-> r) | isEmpty (freeVars e `intersection` def) = do+                exp <- f r+                return (e :>>= l :-> exp)+            f r = return $ updateLetProps lt {  expBody = r }+        f b+    fixupLet exp = return exp+    dropAny mv (exp::Exp) = do+        (nn,xs) <- get+        let (reachable',_graph) = newGraphReachable xs pexpUniq pexpDeps+            deps = justDeps xs (freeVars exp)+            reached = reachable' deps+            --dropped = case prefered reached exp of+            --    Just (x:_) | [] <- [ r | r <- reached, pexpUniq x `elem` pexpDeps r ] -> (reverse $ topSort $ newGraph (filter (/= x) reached) pexpUniq pexpDeps) ++ [x]+            --    _ -> reverse $ topSort $ newGraph reached pexpUniq pexpDeps+            dropped =  reverse $ topSort $ newGraph reached pexpUniq pexpDeps+            ff pexp exp = pexpExp pexp :>>= pexpBind pexp :-> exp+            ebinds = [ Var v t | (v,t) <- Set.toList $ freeVars (map pexpBind dropped) ]+            (exp',mv') | Just vv <- mv = let mv' = vv ++ ebinds in (exp :>>= vv :-> Return mv',mv')+                       | otherwise = (exp,[])+        put (nn,[ x | x <- xs, pexpUniq x `notElem` (map pexpUniq reached) ])+--        when (not $ null dropped) $ lift $ do+--            putStrLn "@@@ dropped"+--            mapM_ Prelude.print dropped+        return (mv',foldr ff exp' dropped :: Exp)+    -- | preferentially pull definitons of the variable this returns right next to it as it admits a peephole optimization+--    prefer (Store v@Var {}) = return v+--    prefer (App fn [v@Var {}] _)  | fn == funcEval = return v+--    prefer (App fn [v@Var {},_] _)| fn == funcApply = return v+--    prefer (App fn [v@Var {}] _)  | fn == funcApply = return v+--    prefer (Update _ v@Var {}) = return v+--    prefer (Update v@Var {} _) = return v+--    prefer _ = fail "no preference"+--    _prefered pexps exp = do+--        v <- prefer exp+--        return [ p | p <- pexps, v == pexpBind p]++--grinPush :: Stats -> Lam -> IO Lam+--grinPush stats lam = ans where+--    ans = do+--        putStrLn "@@@ grinPush"+--        (ans,_) <- evalStateT (whiz subBlock doexp finalExp whizState lam) (1,[])+--        return ans+--    subBlock _ action = do+--        (nn,x) <- get+--        put (nn,mempty)+--        r <- action+--        (nn,_) <- get+--        put (nn,x)+--        return r+--    doexp (v, exp) | isOmittable exp = do+--        (nn,cv) <- get+--        let npexp = makeDeps cv PExp { pexpUniq = nn, pexpBind = v, pexpExp = exp, pexpDeps = undefined, pexpProvides = undefined }+--        put (nn+1,npexp:cv)+--        return Nothing+--    doexp (v, exp) = do+--        exp <- fixupLet exp+--        (v',exp') <- dropAny (Just v) exp+--        return $ Just (v',exp')+--    finalExp (exp::Exp) = do+--        exp <- fixupLet exp+--        (_,exp') <- dropAny Nothing exp+--        return (exp'::Exp)+--    fixupLet lt@Let { expDefs = defs, expBody = b } = do+--        let def = (Set.fromList $ map funcDefName defs)+--            f (e :>>= l :-> r) | Set.null (freeVars e `Set.intersection` def) = do+--                exp <- f r+--                return (e :>>= l :-> exp)+--            f r = return $ updateLetProps lt {  expBody = r }+--        f b+--    fixupLet exp = return exp+--    dropAny mv (exp::Exp) = do+--        (nn,xs) <- get+--        let graph = newGraph xs pexpUniq pexpDeps+--            deps = justDeps xs (freeVars exp)+--            reached = reachable graph deps+--            --dropped = case prefered reached exp of+--            --    Just (x:_) | [] <- [ r | r <- reached, pexpUniq x `elem` pexpDeps r ] -> (reverse $ topSort $ newGraph (filter (/= x) reached) pexpUniq pexpDeps) ++ [x]+--            --    _ -> reverse $ topSort $ newGraph reached pexpUniq pexpDeps+--            dropped =  reverse $ topSort $ newGraph reached pexpUniq pexpDeps+--            ff pexp exp = pexpExp pexp :>>= pexpBind pexp :-> exp+--            ebinds = [ Var v t | (v,t) <- Set.toList $ freeVars (map pexpBind dropped) ]+--            (exp',mv') | Just vv <- mv = let mv' = tuple $ fromTuple vv ++ ebinds in (exp :>>= vv :-> Return mv',mv')+--                       | otherwise = (exp,unit)+--        put (nn,[ x | x <- xs, pexpUniq x `notElem` (map pexpUniq reached) ])+--        when (not $ null dropped) $ lift $ do+--            putStrLn "@@@ dropped"+--            mapM_ Prelude.print dropped+--        return (mv',foldr ff exp' dropped :: Exp)+--    -- | preferentially pull definitons of the variable this returns right next to it as it admits a peephole optimization+--    prefer (Store v@Var {}) = return v+--    prefer (App fn [v@Var {}] _)  | fn == funcEval = return v+--    prefer (App fn [v@Var {},_] _)| fn == funcApply = return v+--    prefer (App fn [v@Var {}] _)  | fn == funcApply = return v+--    prefer (Update _ v@Var {}) = return v+--    prefer (Update v@Var {} _) = return v+--    prefer _ = fail "no preference"+--    prefered pexps exp = do+--        v <- prefer exp+--        return [ p | p <- pexps, v == pexpBind p]++grinSpeculate :: Grin -> IO Grin+grinSpeculate grin = do+    let ss = findSpeculatable grin+    when verbose $ putStrLn "Speculatable:"+    when verbose $ mapM_ Prelude.print ss+    let (grin',stats) = runStatM (performSpeculate ss grin)+    when verbose $ Stats.printStat "Speculate" stats+    return grin'++performSpeculate specs grin = do+    let sset = fromList (map tagFlipFunction specs) :: GSet Tag+    let f (a,l) = mapBodyM h l  >>= \l' -> return (a,l')+        h (BaseOp (StoreNode False) [NodeC t xs]) | t `member` sset = do+            let t' = tagFlipFunction t+            mtick $ "Optimize.speculate.store.{" ++ show t'+            return (App t' xs [TyNode] :>>= [n1] :-> demote n1)+        h e = mapExpExp h e+    fs <- mapM f (grinFuncs grin)+    return $ setGrinFunctions fs grin++findSpeculatable :: Grin -> [Atom]+findSpeculatable grin = ans where+    ans = [ x | Left (x,_) <- scc graph ]+    graph = newGraph [ (a,concatMap f (freeVars l)) | (a,_ :-> l) <- grinFuncs grin, isSpeculatable l, getType l == [TyNode] ] fst snd+    f t | tagIsSuspFunction t = [tagFlipFunction t]+        | tagIsFunction t = [t]+        | otherwise = []+    isSpeculatable Return {} = True+    isSpeculatable (BaseOp (StoreNode _) _) = True+    isSpeculatable (BaseOp Promote _) = True+    isSpeculatable (BaseOp Demote _) = True+    isSpeculatable (x :>>= _ :-> y) = isSpeculatable x && isSpeculatable y+    isSpeculatable (Case e as) = all isSpeculatable [ e | _ :-> e <- as]+    isSpeculatable Prim { expPrimitive = p } = primIsConstant p+    isSpeculatable _ = False++demote x = BaseOp Demote [x]
+ src/Grin/Show.hs view
@@ -0,0 +1,192 @@+module Grin.Show(+    prettyFun,+    prettyExp,+    printGrin,+    hPrintGrin,+    graphGrin,+    render+    ) where++import Data.Char+import Control.Monad.Writer(tell,when,forM_,execWriter)+import Data.Maybe+import System.IO+import qualified Data.Map as Map+import qualified Data.Set as Set++import C.Prims+import Data.Graph.Inductive.Graph(mkGraph)+import Data.Graph.Inductive.Tree+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import Grin.Grin+import Grin.Noodle+import Grin.Val+import Name.VConsts+import Options+import StringTable.Atom+import Support.CanType+import Support.FreeVars+import Util.Graphviz+import qualified Cmm.Op as Op++instance DocLike d => PPrint d Val   where+    pprintAssoc _ _ v = prettyVal v++instance PPrint Doc Exp   where+    pprint v = prettyExp empty v++pVar [] = empty+pVar v  = prettyVals v <+> operator "<- "++pVar' v  = prettyVals v <+> operator "<- "++prettyVals [] = prettyVal Unit+prettyVals [x] = prettyVal x+prettyVals xs = tupled (map prettyVal xs)++operator = text+keyword = text+tag x = text x+func = text+prim = text++isComplex (_ :>>= _) = True+isComplex _ = False++isOneLine (_ :>>= _) = False+isOneLine Case {} = False+isOneLine Let {} = False+isOneLine MkCont {} = False+isOneLine _ = True++{-# NOINLINE prettyExp #-}+prettyExp vl (e1 :>>= v :-> e2) | isComplex e1 = align $ ((pVar' v) <> (prettyExp empty e1)) <$> prettyExp vl e2+prettyExp vl (e1 :>>= v :-> e2) = align (prettyExp (pVar v) e1 <$> prettyExp vl e2)+prettyExp vl (Return []) = vl <> keyword "return" <+> text "()"+prettyExp vl (Return [v]) = vl <> keyword "return" <+> prettyVal v+prettyExp vl (Return vs) = vl <> keyword "return" <+> tupled (map prettyVal vs)+--prettyExp vl (Store v@Var {}) | getType v == tyDNode = vl <> keyword "demote" <+> prettyVal v+--prettyExp vl (Store v) = vl <> keyword "store" <+> prettyVal v+prettyExp vl (Error "" _) = vl <> prim "exitFailure"+prettyExp vl (Error s _) = vl <> keyword "error" <+> tshow s+prettyExp vl (BaseOp Eval [v]) = vl <> keyword "eval" <+> prettyVal v+prettyExp vl (BaseOp Coerce {} [v]) = vl <> keyword "coerce" <+> prettyVal v+prettyExp vl (BaseOp Apply {} vs) = vl <> keyword "apply" <+> hsep (map prettyVal vs)+prettyExp vl (App a vs _)  = vl <> func (fromAtom a) <+> hsep (map prettyVal vs)+prettyExp vl Prim { expPrimitive = (Op (Op.BinOp bo _ _) _), expArgs = [x,y] } | Just (op,_) <- Op.binopInfix bo = vl <> prettyVal x <+> operator op <+> prettyVal y+prettyExp vl Prim { expPrimitive = (Op (Op.BinOp bo _ _) _), expArgs = [x,y] } = vl <> prettyVal x <+> char '`' <> tshow bo <> char '`' <+> prettyVal y+prettyExp vl Prim { expPrimitive = (Peek t), expArgs = [v] }  = vl <> prim (show t) <> char '[' <> prettyVal v <> char ']'+prettyExp vl Prim { expPrimitive = ap, expArgs = vs } = vl <> prim (pprint ap) <+> hsep (map prettyVal vs)+prettyExp vl (GcRoots vs b) = vl <> keyword "withRoots" <> tupled (map prettyVal vs) <$> indent 2 (prettyExp empty b)+prettyExp vl (BaseOp Overwrite [x,y]) = vl <> keyword "overwrite" <+> prettyVal x <+> prettyVal y+prettyExp vl (BaseOp Redirect [x,y]) = vl <> keyword "redirect" <+> prettyVal x <+> prettyVal y+prettyExp vl (BaseOp PokeVal [x,y]) = vl <> keyword "pokeVal" <+> prettyVal x <+> prettyVal y+prettyExp vl (BaseOp PeekVal [x]) = vl <> keyword "peekVal" <+> prettyVal x+prettyExp vl (BaseOp Promote [x]) = vl <> keyword "promote" <+> prettyVal x+prettyExp vl (BaseOp NewRegister xs) = vl <> keyword "register" <+> tupled (map prettyVal xs)+prettyExp vl (BaseOp WriteRegister [r,x]) = vl <> prettyVal r <+> keyword ":=" <+> prettyVal x+prettyExp vl (BaseOp ReadRegister [r]) = vl <> keyword "*" <> prettyVal r+prettyExp vl (BaseOp GcPush xs) = vl <> keyword "gcPush" <+> tupled (map prettyVal xs)+prettyExp vl (BaseOp GcTouch xs) = vl <> keyword "gcTouch" <+> tupled (map prettyVal xs)+prettyExp vl (BaseOp Demote [x]) = vl <> keyword "demote" <+> prettyVal x+prettyExp vl (BaseOp (StoreNode b) [x]) = vl <> keyword ((if b then "d" else "i") ++ "store") <+> prettyVal x+prettyExp vl (BaseOp (StoreNode b) [x,y]) = vl <> keyword ((if b then "d" else "i") ++ "store") <+> prettyVal x <> char '@' <> prettyVal y+prettyExp vl (Case v vs) = vl <> keyword "case" <+> prettyVal v <+> keyword "of" <$> indent 2 (vsep (map f vs)) where+    f (~[v] :-> e) | isOneLine e = prettyVal v <+> operator "->" <+> prettyExp empty e+    f (~[v] :-> e) = prettyVal v <+> operator "->" <+> keyword "do" <$> indent 2 (prettyExp empty e)+prettyExp vl NewRegion { expLam = (r :-> body)} = vl <> keyword "region" <+> text "\\" <> prettyVals r <+> text "-> do" <$> indent 2 (prettyExp empty body)+--prettyExp vl MkCont { expCont = (r :-> body) } = vl <> keyword "continuation" <+> text "\\" <> prettyVal r <+> text "-> do" <$> indent 2 (prettyExp empty body)+prettyExp vl Let { expDefs = defs, expBody = body, .. } = vl <> keyword (if expIsNormal then "let" else "let*") <$> indent 4 (vsep $ map f defs) <$> text " in" <$> indent 2 (prettyExp empty body) where+    f FuncDef { funcDefName = name, funcDefBody = as :-> body } = func (show name) <+> hsep (map prettyVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty body)+prettyExp vl Alloc { expValue = val, expCount = Lit n _, expRegion = r }| n == 1 = vl <> keyword "alloc" <+> prettyVal val <+> text "at" <+> prettyVal r+prettyExp vl Alloc { expValue = val, expCount = count, expRegion = r } = vl <> keyword "alloc" <+> prettyVal val <> text "[" <> prettyVal count <> text "]" <+> text "at" <+> prettyVal r+prettyExp vl Call { expValue = Item t (TyCall fun _ _), expArgs = vs, expJump = jump } | fun `elem` [Function,LocalFunction] =  vl <> f jump  <+> func (fromAtom t) <+> hsep (map prettyVal vs) where+    f True = text "jump to"+    f False = text "call"+prettyExp vl Call { expValue = Var v (TyCall fun _ _), expArgs = vs, expJump = jump}  =  vl <> f jump fun  <+> pprint v <+> hsep (map prettyVal vs) where+    f False Continuation = text "cut to"+    f False Function = text "call"+    f True Function = text "jump to"+    f False Closure = text "enter"+    f True Closure = text "jump into"+    f x y = tshow (x,y)+prettyExp vl Call { expValue = ValPrim ap [] (TyCall Primitive' _ _), expArgs = vs } = vl <> prim (tshow ap) <+> hsep (map prettyVal vs)+prettyExp vl y = vl <> tshow y++{-# NOINLINE prettyVal #-}+prettyVal :: DocLike d => Val -> d+prettyVal s | Just [] <- valToList s = text "[]"+prettyVal s | Just st <- fromVal s = text $ show (st::String)+prettyVal s | Just vs <- valToList s = list $ map prettyVal vs+prettyVal (NodeC ch [t]) | ch == toAtom "CJhc.Prim.Char" =  parens $ text "Char" <+> sc t where+    sc (Lit n t) | t == tCharzh = tshow (chr $ fromIntegral n)+    sc v = prettyVal v+prettyVal (NodeC t []) = parens $ tag (fromAtom t)+prettyVal (NodeC t vs) = parens $ tag (fromAtom t) <+> hsep (map prettyVal vs)+prettyVal (Index p off) = prettyVal p <> char '[' <> prettyVal off <> char ']'+prettyVal v@Var {} = tshow v+prettyVal (Lit i _)  = tshow i+prettyVal (Const v) = char '&' <> prettyVal v+prettyVal (ValUnknown ty) = text "?::" <> tshow ty+prettyVal Unit = text "()"+prettyVal (Item a  ty) = tshow a <> text "::" <> tshow ty+prettyVal (ValPrim aprim args ty) = f aprim args where+    f aprim [] = pprint aprim <> text "::" <> tshow ty+    f ((Op (Op.BinOp bo _ _) _)) [x,y] | Just (op,prec) <- Op.binopInfix bo = parens (pprintPrec prec x <+> text op <+> pprintPrec prec y)+    f ((Op (Op.BinOp bo _ _) _)) [x,y] =  parens $ pprintPrec 1 x <+> char '`' <> tshow bo <> char '`' <+> pprintPrec 1 y+    f aprim xs = pprint aprim <> tupled (map prettyVal xs) <> text "::" <> tshow ty++instance DocLike d => PPrint d Var where+    pprint (V i) = text $ 'v':show i+--pv (V 0) = char '_'+--pv (V i) = char 'v' <> tshow i++prettyFun :: (Atom,Lam) -> Doc+prettyFun (n,(as :-> e)) = func (fromAtom n) <+> hsep (map prettyVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty e)++render :: Doc -> String+render doc =  displayS (renderPretty 0.95 (optColumns options)  doc) ""++printGrin :: Grin -> IO ()+printGrin grin = hPrintGrin stderr grin++hPrintGrin :: Handle -> Grin -> IO ()+hPrintGrin handle grin@Grin { grinCafs = cafs } = do+    when (not $ null cafs) $ do+        hPutStrLn handle "-- Cafs"+        mapM_ (hPutStrLn handle) $ map (\(x,y) -> show x ++ " := " ++  render (prettyVal y))  cafs+    hPutStrLn handle "-- Functions"+    forM_ (grinFuncs grin) $ \ f@(n,l :-> e) -> do+        hPutStrLn handle . render $ func (fromAtom n) <+> operator "::" <+> tupled (map (tshow . getType) l)  <+> operator "->" <+> tupled (map tshow (getType e))+        hPutStrLn handle (render $ prettyFun f)+        hPutStrLn handle ""++{-# NOINLINE graphGrin #-}++graphGrin :: Grin -> String+graphGrin grin = graphviz' gr [] fnode fedge  where+    nodes = zip [0..] (grinFuncs grin)+    nodeMap = Map.fromList [ (y,x) | (x,(y,_)) <- nodes]+    gr :: Gr (Atom,Lam) CallType+    gr =   mkGraph nodes [ (n,n2,tc) | (n,(_,_ :-> l)) <- nodes, (tc,fv) <- Set.toList (freeVars l), n2 <- maybeToList $ Map.lookup fv nodeMap ]+    fnode :: (Atom,Lam) -> [(String,String)]+    fnode (x,_ :-> e) = [("label",show x)]+        ++ (if hasError e then [("color","red")] else [])+        ++ (if x `elem` grinEntryPointNames grin then [("shape","box")] else [])+    fedge :: CallType -> [(String,String)]+    fedge TailCall = []+    fedge StandardCall = [("style","dotted")]++hasError x = isNothing (hasError' x)+hasError' Error {} = Nothing+hasError' e = mapExpExp hasError' e++data CallType = TailCall | StandardCall+    deriving(Ord,Show,Eq)++instance FreeVars Exp (Set.Set (CallType,Atom)) where+    freeVars (a :>>= _ :-> b) = freeVars b `Set.union` Set.map (\ (_ :: CallType,y) -> (StandardCall, y)) (freeVars a)+    freeVars (App a _ _) = Set.singleton (TailCall,a)+    freeVars e = execWriter $ mapExpExp (\e -> tell (freeVars e) >> return e) e
+ src/Grin/Show.hs-boot view
@@ -0,0 +1,9 @@+module Grin.Show where++import Doc.Pretty+import Atom+import {-# SOURCE #-} Grin.Grin++prettyFun :: (Atom.Atom,Grin.Grin.Lam) -> Doc.Pretty.Doc+prettyExp :: Doc.Pretty.Doc -> Grin.Grin.Exp -> Doc.Pretty.Doc+prettyVal :: Grin.Grin.Val -> Doc.Pretty.Doc
+ src/Grin/StorageAnalysis.hs view
@@ -0,0 +1,130 @@+module Grin.StorageAnalysis(storeAnalyze) where++import Control.Monad.Identity+import Control.Monad.Writer+import Data.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set++import Grin.Grin+import Grin.Noodle+import Grin.Val+import Options+import StringTable.Atom+import Support.FreeVars+import Support.Tickle+import Util.Gen+import Util.UnionSolve+import Util.UniqueMonad+import qualified FlagOpts as FO++data T = S | E+    deriving(Eq,Show)++instance Fixable T where+    join S S = S+    join _ _ = E++    meet E E = E+    meet _ _ = S++    isTop x = E == x+    isBottom x = S == x++    eq = (==)++    lte E S = False+    lte _ _ = True++data Vr+    = Vb !Var         -- ^ inner variable+    | Va !Atom !Int   -- ^ function argument+    | Vr !Var         -- ^ region variable+    deriving(Eq,Ord)++instance Show Vr where+    showsPrec _ (Vb v) = shows v+    showsPrec _ (Va a i) = shows (a,i)+    showsPrec _ (Vr (V n)) = showChar 'r' . shows n++{-# NOINLINE storeAnalyze #-}+storeAnalyze :: Grin -> IO Grin+storeAnalyze grin | fopts FO.Jgc = return grin+storeAnalyze grin = do+    --dumpGrin "storeAnalyze1" grin+    let (grin',cs) = execUniq1 $ runWriterT (mapGrinFuncsM firstLam grin)+    --dumpGrin "storeAnalyze2" grin'+    (rm,res) <- solve (const $ return ()) cs+ --   (rm,res) <- solve putStrLn cs+ --   putStrLn "----------------------------"+ --   mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList rm)+ --   putStrLn "----------------------------"+ --   mapM_ print (Map.elems res)+ --   putStrLn "----------------------------"+    let cmap = Map.filterWithKey fm $ Map.map (lower . fromJust . flip Map.lookup res) rm+        lower (ResultJust _ j) = j+        lower ResultBounded { resultLB = Nothing } = S+        lower _ = error "StorageAnalysis.storeAnalyze: bad."+        fm _ E = False+        fm (Vr _) _ = True+        fm (Va _ _) _ = True+        fm _ _ = False+    mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList cmap)+    let grin'' = runIdentity $ tickleM (lastLam cmap) grin'+    return grin''++isHeap TyNode = True+isHeap TyINode = True+--isHeap TyPtr {} = True+isHeap _ = False++firstLam fname lam = g Nothing fname lam where+    g wtd fname (as :-> body) = do+        tell $ mconcat [ Left (Vb v) `equals` Left (Va fname n) | (n,Var v t) <- zip naturals as, isHeap t ]+        let f wtd (BaseOp (StoreNode sh) [n@(NodeC _ vs)]) = do+                vu <- V `liftM` newUniq+                g wtd [[Vr vu]]+                tell $ mconcat [ Left (Vr vu) `islte` Left v | v' <- toVs vs, v <- v'  ]+                return (BaseOp (StoreNode sh) [n,Var vu TyRegion])+            f wtd (e :>>= as :-> body) = do+                e' <- f (Just as) e+                body' <- f wtd body+                return (e' :>>= as :-> body')+            f wtd (Case e as) = Case e `liftM` mapM (tickleM  (f wtd)) as+            f wtd (Return xs) = g wtd (toVs xs) >> return (Return xs)+            f wtd e@(BaseOp Promote xs) = g wtd (toVs xs) >> return e+            f wtd e@(BaseOp Demote xs) = g wtd (toVs xs) >> return e+            f wtd e@(BaseOp Redirect xs) = g Nothing (toVs xs) >> return e+            f wtd e@(BaseOp Overwrite [Var v _,n]) = do tell $ mconcat [ Left (Vb v) `islte` Left r | r <- concat $ toVs [n] ] ; return e+            f wtd e@(App fn vs ty) = do+                tell $ mconcat [ Left (Va fn n) `islte` Left (Vb v) | (n,Var v t) <- zip naturals vs, isHeap t ]+                return e+            f wtd e@(Let { expDefs = defs, expBody = b }) = do+                defs' <- mapM (tickleM (g' wtd)) defs+                b <- f wtd b+                return $ updateLetProps e { expDefs = defs', expBody = b }+            f wtd e =  do+                let zs = Set.toList (Set.map (Vb . fst) $ Set.filter (isHeap . snd) (freeVars e))+                tell $ mconcat [ Right E `islte` Left r | r <- zs ];+                return e++            g Nothing vs = tell $ mconcat [ Right E `islte` Left v | v' <- vs, v <- v' ]+            g (Just as) vs = tell $ mconcat [ Left a `islte` Left v | (a',v') <- zip (toVs as) vs, a <- a', v <- v']++            toVs :: [Val] -> [[Vr]]+            toVs xs = f xs [] where+                f [] rs = reverse rs+                f (x:xs) rs = f xs (Set.toList (Set.map (Vb . fst) $ Set.filter (isHeap . snd) (freeVars x)):rs)+        b <- f wtd body+        return (as :-> b)+    g' wtd (fname,b) = do+        b <- g wtd fname b+        return (fname,b)++lastLam :: Map.Map Vr T -> Lam -> Identity Lam+lastLam cmap  lam = tickleM f lam where+    f (BaseOp (StoreNode sh) [n,Var r TyRegion]) = do+        case Map.lookup (Vr r) cmap of+            Just S -> return (BaseOp (StoreNode sh) [n,region_stack])+            _ ->  return (BaseOp (StoreNode sh) [n])+    f e = tickleM f e
+ src/Grin/Unboxing.hs view
@@ -0,0 +1,115 @@+module Grin.Unboxing(unboxReturnValues) where++import Maybe+import Monad+import qualified Data.Map as Map+import qualified Data.Set as Set++import GenUtil+import Grin.Grin+import StringTable.Atom+import Support.CanType+import Support.Tuple+import Util.Graph++tailcalls :: Lam -> Set.Set Atom+tailcalls (_ :-> e) = f e where+    f (_ :>>= l) = tailcalls l+    f App { expFunction = fn } = Set.singleton fn+    f Case { expAlts = as } = Set.unions (map tailcalls as)+    f _ = Set.empty++unboxingCandidate :: Item -> Bool+unboxingCandidate item = isJust (unboxFunction undefined item)++isEnum (NV _ []) = True+isEnum _ = False++unboxFunction :: Monad m => Atom -> Item -> m (Exp -> Exp, Exp -> Exp, Ty, Item)+unboxFunction _ x | getType x == tyUnit = fail "unboxFunction: return type is already ()"+-- get rid of any fully constant values in return+unboxFunction fn item | any isLeft rvs = return (unboxReturn, unboxCall, returnType, nvs) where+    vs = fromTuple item+    rvs = [ case constantItem v of Just x -> Left x ; _ -> Right v | v <- vs ]+    nvs = tuple (rights rvs)+    returnType = getType nvs+    unboxReturn e = e :>>= tuple vars :-> Return (tuple vars')+    unboxCall (App a as _) | a == fn = App a as returnType :>>= tuple vars' :-> Return (tuple [ case x of Left x -> x ; Right _ -> v |  v <- vars | x <- rvs ])+    vars  = [Var v t | v <- [v1 ..] | t <- map getType vs ]+    vars' = concat [ perhapsM (isRight r) (Var v t)  | v <- [v1 ..] | t <- map getType vs | r <- rvs ]++-- unbox enumerated types+unboxFunction fn (NodeValue vs) | all isEnum (Set.toList vs) = return (unboxReturn, unboxCall, TyTag, itemTag) where+    unboxReturn (Return (NodeC t [])) = Return (Tag t)+    unboxReturn e = e :>>= nodev :-> Return var+    unboxCall (App a as ty) = App a as TyTag :>>= var :-> Return nodev+    var = Var v1 TyTag+    nodev = NodeV v1 []++-- returning a known node type+unboxFunction fn (NodeValue vs) | [NV t args] <- Set.toList vs  =  let+    returnType = tuple (map getType args)+    unboxReturn (Return (NodeC t' xs))+        | t == t' = Return (tuple xs)+        | otherwise = error "returning wrong node"+    unboxReturn e = e :>>= NodeC t vars :-> Return (tuple vars)+    unboxCall (App a as _) | a == fn = App a as returnType :>>= tuple vars :-> Return (NodeC t vars)+    vars  = [Var v t | v <- [v1 ..] | t <- map getType args ]+    in return (unboxReturn, unboxCall, returnType, tuple args)++unboxFunction _ item = fail "function not unboxable" -- (id,id,getType item)++constantItem (NodeValue vs) | [NV t xs] <- Set.toList vs  = do+    xs <- mapM constantItem xs+    return (NodeC t xs)+constantItem (TupledValue xs) = do+    xs <- mapM constantItem xs+    return (Tup xs)+constantItem (HeapValue vs) | [HV _ (Right val)] <- Set.toList vs  = do+    return (Const val)+constantItem _ = fail "not constant item"++{-# NOINLINE unboxReturnValues #-}+unboxReturnValues :: Grin -> IO Grin+unboxReturnValues grin = do+    let tcgraph = newGraph [ (n, Set.toList $ tailcalls body) | (n,body) <- grinFuncs  grin] fst snd+        ubc a | Just v <- Map.lookup a (grinReturnTags grin) = unboxingCandidate v+        ubc _ = False+        cfns = filter ubc (fsts $ grinFuncs grin)+        pf fn | Just item <- Map.lookup fn (grinReturnTags grin) =+            do x <- unboxFunction fn item ; return $ Map.singleton fn x+        fns = Map.unions $ concatMap pf cfns+        retTag fn _ | Just (_,_,_,ret) <- Map.lookup fn fns = ret+        retTag _ x = x+        retTe fn tyty | Just (_,_,ret,_) <- Map.lookup fn fns = tyty { tyReturn = ret }+        retTe _ x = x+        mtenv (TyEnv mp) = TyEnv $ Map.mapWithKey retTe mp+        doFunc (fn,lam) | Just (unboxReturn,_,_,_) <- Map.lookup fn fns = doFunc' (fn,convertReturns unboxReturn lam)+        doFunc (fn,lam) = doFunc' (fn,lam)+        doFunc' (fn,lam) = (fn, convertApps doApp lam)+        doApp ap@(App fn _ _) | Just (_,f,_,_) <- Map.lookup fn fns = f ap+        doApp e = e+    putStrLn "Unboxed return values"+    mapM_ putStrLn [ "  " ++ show fn ++ " - " ++  show nt | (fn,(_,_,nt,_)) <- Map.toList fns]++    let newgrin = setGrinFunctions (map doFunc (grinFuncs grin)) grin {+        grinReturnTags = Map.mapWithKey retTag (grinReturnTags grin),+        grinTypeEnv = mtenv (grinTypeEnv grin)+        }+    if Map.null fns then return newgrin else unboxReturnValues newgrin++convertReturns unboxReturn lam = g lam where+    g (l :-> e) = l :-> f e+    f (e :>>= l) = e :>>= g l+    f e@Case { expAlts = as } = e { expAlts = map g as }+    f e@Let { expBody = b } = e { expBody = f b }+    f e@MkCont { expCont = c , expLam = b } = e { expCont = g c, expLam = g b }+    f e = unboxReturn e++convertApps doApp lam = g lam where+    g (l :-> e) = l :-> f e+    f (e :>>= l) = f e :>>= g l+    f e@Case { expAlts = as } = e { expAlts = map g as }+    f e@Let { expDefs = defs, expBody = b } = e { expBody = f b, expDefs = [ createFuncDef True (funcDefName d) (g $ funcDefBody d) | d <- defs ] }+    f e@MkCont { expCont = c , expLam = b } = e { expCont = g c, expLam = g b }+    f e = doApp e
+ src/Grin/Val.hs view
@@ -0,0 +1,116 @@+module Grin.Val(+    FromVal(..),+    ToVal(..),+    tn_2Tup,+    valToList,+    cChar,+    cWord,+    cInt,+    convertName,+    region_heap,+    region_atomic_heap,+    region_stack,+    region_block+    ) where++import Data.Char++import Cmm.Number+import Grin.Grin+import Name.Name+import Name.Names+import Name.VConsts+import StringTable.Atom++nil      = convertName dc_EmptyList+cons     = convertName dc_Cons+cChar    = convertName dc_Char+cWord    = convertName dc_Word+cInt     = convertName dc_Int+tn_2Tup  = convertName $ nameTuple DataConstructor 2+tn_Boolzh = convertName dc_Boolzh+tn_unit  = convertName dc_Unit++-- This allocates data on the heap.+region_heap  = Item (toAtom "heap") TyRegion+-- This allocates data on the atomic heap.+region_atomic_heap  = Item (toAtom "atomicHeap") TyRegion+-- This allocates data in the innermost enclosing region, including implicit regions.+region_block = Item (toAtom "block") TyRegion+-- This allocates data on the stack, generally equivalent to 'block' for most back ends.+region_stack = Item (toAtom "stack") TyRegion++instance ConNames Val where+    vTrue  = NodeC tn_Boolzh [toUnVal (1 :: Int)]+    vFalse = NodeC tn_Boolzh [toUnVal (0 :: Int)]+    vUnit  = NodeC tn_unit []++class ToVal a where+    toVal :: a -> Val+    toUnVal :: a -> Val+    toUnVal x = toVal x++class FromVal a where+    fromVal :: Monad m => Val -> m a+    fromUnVal :: Monad m => Val -> m a+    fromUnVal x = fromVal x++instance ToVal Bool where+    toVal True = vTrue+    toVal False = vFalse++instance ToVal a => ToVal [a] where+    toVal [] = NodeC nil []+    toVal (x:xs) =  NodeC cons [Const (toVal x),Const (toVal xs)]+instance  ToVal (Val,Val) where+    toVal (x,y) = NodeC tn_2Tup [x,y]++instance ToVal Char where+    toVal c = NodeC cChar [toUnVal c]+    toUnVal c =   Lit (fromIntegral $ ord c) tIntzh+instance ToVal Int where+    toVal c = NodeC cInt [toUnVal c]+    toUnVal c =  Lit (fromIntegral c) tIntzh++instance ToVal Val where+    toVal x = x++instance FromVal Int where+    fromVal (NodeC _ [Lit i _]) | Just x <- toIntegral i = return x+    fromVal n = fail $ "Val is not Int: " ++ show n+    fromUnVal (Lit i _) | Just x <- toIntegral i = return x+    fromUnVal n = fail $ "Val is not UnInt: " ++ show n+instance FromVal Char where+    fromVal (NodeC _ [Lit i _]) | Just x <- toIntegral i, x >= ord minBound && x <= ord maxBound = return (chr x)+    fromVal n = fail $ "Val is not Char: " ++ show n+    fromUnVal (Lit i _) | Just x <- toIntegral i, x >= ord minBound && x <= ord maxBound = return (chr x)+    fromUnVal n = fail $ "Val is not UnChar: " ++ show n++instance FromVal a => FromVal [a] where+    fromVal (NodeC n [])  | n == nil = return []+    fromVal (NodeC n [Const a,Const b]) | n == cons = do+        x <- fromVal a+        xs <- fromVal b+        return (x:xs)+    fromVal n = fail $ "Val is not [a]: " ++ show n++instance FromVal Bool  where+    fromVal n+        | n == toVal True = return True+        | n == toVal False = return False+    fromVal n = fail $ "Val is not Bool: " ++ show n+instance FromVal Val where+    fromVal n = return n++valToList (NodeC n []) | n == nil = return []+valToList (NodeC n [a,Const b]) | n == cons = do+        xs <- valToList b+        return (a:xs)+valToList n = fail $ "Val is not [a]: " ++ show n++convertName n = toAtom (t':s) where+    (t,s) = fromName n+    t' | t == TypeConstructor = 'T'+       | t == DataConstructor = 'C'+       | t == Val = 'f'+       | otherwise = error $ "convertName: " ++ show (t,s)
+ src/Grin/Whiz.hs view
@@ -0,0 +1,211 @@+module Grin.Whiz(whiz, fizz, WhizState, whizState, normalizeGrin,normalizeGrin', applySubstE, applySubst, whizExps) where++import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Writer+import Util.GMap+import Util.HasSize+import Util.SetLike+import qualified Data.Set as Set++import Grin.Grin+import Grin.Noodle+import Support.CanType++type WhizState = Either (Set.Set Int) Int+type WhizEnv = GMap Var Val++whizState :: WhizState+whizState = Left mempty++--normalizeGrin :: Grin -> Grin+--normalizeGrin grin@Grin { grinFunctions = fs } = grin { grinFunctions = f fs [] (Right 1) } where+--    f [] xs _ = xs+--    f ((a,(Tup vs,fn)):xs) ys set = f xs ((a,(Tup vs',fn')):ys) set' where+--        (Identity ((NodeC _ vs',fn'),set')) = whiz return return set (NodeC tagHole vs , fn)+normalizeGrin :: Grin -> Grin+normalizeGrin grin = setGrinFunctions (f (grinFuncs grin) [] (Right 1)) grin  where+    f [] xs _ = reverse xs+    f ((a,lm):xs) ys set = f xs ((a,lm'):ys) set' where+        (Identity (lm',set')) = fizz  (\_ x -> x) (return . Just) return set lm++normalizeGrin' :: Grin -> Grin+normalizeGrin' grin = setGrinFunctions (f (grinFuncs grin) []) grin  where+    f [] xs  = reverse xs+    f ((a,lm):xs) ys  = f xs ((a,lm'):ys) where+        (Identity (lm',_)) = whiz (\_ x -> x) (return . Just) return (Right 1) lm++whizExps :: Monad m => (Exp -> m Exp) -> Lam -> m Lam+whizExps f l = liftM fst $ whiz (\_ x -> x) (\(p,e) -> f e >>= \e' -> return  (Just (p,e'))) f whizState l++-- | magic traversal and flattening routine.+-- whiz traverses Grin code and right assosiates it as well as renaming and+-- repeated variables along the way.+-- in addition, it provides a nice monadic traversal of the flattened renamed code suitable+-- for a wide range of grin -> grin transformations.+-- basically, you may use 'whiz' to perform tranformations which do not require lookahead, and depend+-- only on the code that happened before.+-- note that a case is presented after all of its sub code blocks have been processed+-- Whiz also vectorizes tuple->tuple assignments, breaking them into individual assignments+-- for its components to better aid future optimizations.++whiz :: Monad m =>+    (forall a . [Val] -> m a -> m a)         -- ^ called for each sub-code block, such as in case statements+    -> (([Val],Exp) -> m (Maybe ([Val],Exp)))  -- ^ routine to transform or omit simple bindings+    -> (Exp -> m Exp)       -- ^ routine to transform final statement in code block+    -> WhizState            -- ^ Initial state+    -> Lam                  -- ^ input lambda expression+    -> m (Lam,WhizState)+whiz sub te tf inState start = res where+    res = runStateT (dc mempty start) inState+    f (a :>>= (v :-> b)) xs env = f a ((env,v,b):xs) env+    f a@(Return (xs@(_:_:_))) ((senv,p@(ys@(_:_:_)),b):rs) env | length xs == length ys  = do+        Return xs <- g env a+        (ys,env') <- renamePattern p+        ts <- lift $ mapM te [([y],Return [x]) | x <- xs | y <- ys ]+        z <- f b rs (env' `mappend` senv)+        let h [] = z+            h ((p,v):rs) = v :>>= p :-> h rs+        return $ h [ (p,v) |  Just (p,v) <- ts]+    f a ((senv,p,b):xs) env = do+        a <- g env a+        (p,env') <- renamePattern p+        x <- lift $ te (p,a)+        z <- f b xs (env' `mappend` senv)+        case x of+            Just (p',a') -> do+                return $ a' :>>= (p' :-> z)+            Nothing -> do+                return z+    f x [] env = do+        x <- g env x+        lift $ tf x+    g env (Case v as) = do+        v <- applySubst env v+        as <- mapM (dc env) as+        return $ Case v as+    g env (GcRoots vs body) = do+        vs <- mapM (applySubst env) vs+        body <- f body [] env+        return $ GcRoots vs body+--    g env lt@Let { expDefs = defs, expBody = Let { expDefs = defs', expBody = body } } = g env lt { expDefs = defs `mappend` defs', expBody = body }+    g env lt@Let { expDefs = defs, expBody = body } = do+        body <- f body [] env+        let f def@FuncDef { funcDefName = n, funcDefBody = b } = do+                b <- dc env b+                return $ createFuncDef True n b+        defs <- mapM f defs+        return $ updateLetProps lt { expBody = body, expDefs = defs }+    g env x = applySubstE env x+    dc env (p :-> e) = do+        (p,env') <- renamePattern p+        g <- get+        (z,g) <- lift $ sub p $ runStateT  (f e [] (env' `mappend` env)) g+        put g+        return (p :-> z)++-- | magic traversal and flattening routine.+-- whiz traverses Grin code and right assosiates it as well as renaming and+-- repeated variables along the way.+-- in addition, it provides a nice monadic traversal of the flattened renamed code suitable+-- for a wide range of grin -> grin transformations.+-- basically, you may use 'whiz' to perform tranformations which do not require lookahead, and depend+-- only on the code that happened before.+-- note that a case is presented after all of its sub code blocks have been processed+-- Whiz also vectorizes tuple->tuple assignments, breaking them into individual assignments+-- for its components to better aid future optimizations.+-- fizz is similar to whiz, but processes things in 'bottom-up' order.+-- fizz also removes all statements past an Error.++fizz :: Monad m =>+    (forall a . [Val] -> m a -> m a)         -- ^ called for each sub-code block, such as in case statements+    -> (([Val],Exp) -> m (Maybe ([Val],Exp)))  -- ^ routine to transform or omit simple bindings+    -> (Exp -> m Exp)       -- ^ routine to transform final statement in code block+    -> WhizState            -- ^ Initial state+    -> Lam                  -- ^ input lambda expression+    -> m (Lam,WhizState)+fizz sub te tf inState start = res where+    res = runStateT (dc mempty start) inState+    f (a :>>= (v :-> b)) xs env = f a ((env,v,b):xs) env+    f a@(Return (xs@(_:_:_))) ((senv,p@ys,b):rs) env | length xs == length ys  = do+        Return xs <- g env a+        (ys,env') <- renamePattern p+        z <- f b rs (env' `mappend` senv)+        ts <- lift $ mapM te (reverse [([y],Return [x]) | x <- xs | y <- ys ])+        let h [] = z+            h ((p,v):rs) = v :>>= p :-> h rs+        return $ h [ (p,v) |  Just (p,v) <- reverse ts]+    f (Error msg ty) [] env = do+        lift $ tf (Error msg ty)+    f (Error msg ty) ((_,_,b):xs) env = do+        f (Error msg (getType b)) xs env+    f a ((senv,p,b):xs) env = do+        a <- g env a+        (p,env') <- renamePattern p+        z <- f b xs (env' `mappend` senv)+        x <- lift $ te (p,a)+        case x of+            Just (p',a') -> do+                return $ a' :>>= (p' :-> z)+            Nothing -> do+                return z+    f x [] env = do+        x <- g env x+        lift $ tf x+    g env (Case v as) = do+        v <- applySubst env v+        as <- mapM (dc env) as+        return $ Case v as+    g env (GcRoots vs body) = do+        vs <- mapM (applySubst env) vs+        body <- f body [] env+        return $ GcRoots vs body+    g env lt@Let { expDefs = defs, expBody = body } = do+        body <- f body [] env+        let f def@FuncDef { funcDefName = n, funcDefBody = b } = do+                b <- dc env b+                return $ createFuncDef True n b+        defs <- mapM f defs+        return $ updateLetProps lt { expBody = body, expDefs = defs }+    g env x = applySubstE env x+    dc env (p :-> e) = do+        (p,env') <- renamePattern p+        g <- get+        (z,g) <- lift $ sub p $ runStateT  (f e [] (env' `mappend` env)) g+        put g+        return (p :-> z)++applySubstE env x = mapExpVal (applySubst env) x++applySubst env x = f x where+    f var@(Var v _)+        | Just n <- mlookup v env =  return n+    f x = mapValVal f x++renamePattern :: MonadState (WhizState) m => [Val] ->  m ([Val],WhizEnv)+renamePattern x = runWriterT (mapM f x) where+    f :: MonadState (WhizState) m => Val -> WriterT (WhizEnv) m Val+    f (Var v t) = do+        v' <- lift $ newVarName v+        let nv = Var v' t+        tell (msingleton v nv)+        return nv+    f (NodeC t vs) = do+        vs' <- mapM f vs+        return $ NodeC t vs'+    f (Index a b) = return Index `ap` f a `ap` f b+    f x = return x++newVarName :: MonadState WhizState m => Var -> m Var+newVarName (V sv) = do+    s <- get+    case s of+        Left s -> do+            let nv = v sv+                v n | n `member` s = v (n + size s)+                    | otherwise = n+            put (Left $! insert nv s)+            return (V nv)+        Right n -> do+            put $! (Right $! (n + 1))+            return $ V n
+ src/Ho/Binary.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE ImpredicativeTypes #-}+module Ho.Binary(readHoFile,recordHoFile,readHlFile,recordHlFile) where++import Codec.Compression.Zlib+import Control.Monad+import Data.Binary+import System.Directory+import Text.Printf+import Util.Gen+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Version++import FrontEnd.Rename(FieldMap(..))+import Ho.Type+import Name.Binary()+import Options+import Support.CFF+import Support.MapBinaryInstance+import Support.CompatMingw32++current_version :: Int+current_version = 11++readHFile :: FilePath -> IO (FilePath,HoHeader,forall a . Binary a => ChunkType -> a)+readHFile fn = do+    bs <- BS.readFile fn+    fn' <- shortenPath fn+    (ct,mp) <- bsCFF bs+    True <- return $ ct == cff_magic+    let fc ct = case lookup ct mp of+            Nothing -> error $ "No chunk '" ++ show ct ++ "' found in file " ++ fn+            Just x -> decode . decompress $ LBS.fromChunks [x]+    let hoh = fc cff_jhdr+    when (hohVersion hoh /= current_version) $ fail "invalid version in hofile"+    return (fn',hoh,fc)++readHoFile :: FilePath -> IO (HoHeader,HoIDeps,Ho)+readHoFile fn = do+    (_fn,hoh,fc) <- readHFile fn+    let Left modGroup = hohName hoh+    return (hoh,fc cff_idep,Ho { hoModuleGroup = modGroup, hoTcInfo = fc cff_defs, hoBuild = fc cff_core})++recordHoFile ::+    Ho               -- ^ File to record+    -> HoIDeps+    -> [FilePath]    -- ^ files to write to+    -> HoHeader      -- ^ file header+    -> IO ()+recordHoFile ho idep fs header = do+    if optNoWriteHo options then do+        when verbose $ do+            fs' <- mapM shortenPath fs+            putErrLn $ "Skipping Writing Ho Files: " ++ show fs'+      else do+    let removeLink' fn = iocatch  (removeFile fn)  (\_ -> return ())+    let g (fn:fs) = do+            f fn+            mapM_ (l fn) fs+            return ()+        g [] = error "Ho.g: shouldn't happen"+        l fn fn' = do+            when verbose $ do+                fn_ <- shortenPath fn+                fn_' <- shortenPath fn'+                when (optNoWriteHo options) $ putErr "Skipping "+                putErrLn $ printf "Linking haskell object file: %s to %s" fn_' fn_+            if optNoWriteHo options then return () else do+            let tfn = fn' ++ ".tmp"+            removeLink' tfn+            createLinkCompat fn tfn+            renameFile tfn fn'+        f fn = do+            when verbose $ do+                when (optNoWriteHo options) $ putErr "Skipping "+                fn' <- shortenPath fn+                putErrLn $ "Writing haskell object file: " ++ fn'+            if optNoWriteHo options then return () else do+            let tfn = fn ++ ".tmp"+                cfflbs = mkCFFfile cff_magic [+                    (cff_jhdr, compress $ encode header { hohVersion = current_version }),+                    (cff_idep, compress $ encode idep),+                    (cff_defs, compress $ encode $ hoTcInfo ho),+                    (cff_core, compress $ encode $ hoBuild ho)]+            LBS.writeFile tfn cfflbs+            renameFile tfn fn+    g fs++recordHlFile+    :: Library+    -> IO ()+recordHlFile l = do+    --let theho =  mapHoBodies eraseE ho+    let cfflbs = mkCFFfile cff_magic $ [+            (cff_jhdr, compress $ encode (libHoHeader l) { hohVersion = current_version }),+            (cff_libr, compress $ encode $ libHoLib l),+            (cff_ldef, compress $ encode $ libTcMap l),+            (cff_lcor, compress $ encode $ libBuildMap l),+            (cff_file, compress $ encode $ libExtraFiles l)]+    let tfp = libFileName l ++ ".tmp"+    LBS.writeFile tfp cfflbs+    renameFile tfp $ libFileName l++readHlFile :: FilePath -> IO Library+readHlFile fn = do+    (_fn',hoh,fc) <- readHFile fn+    return Library { libHoHeader = hoh, libHoLib =  fc cff_libr,+        libTcMap = fc cff_ldef, libBuildMap = fc cff_lcor,+        libFileName = fn, libExtraFiles = fc cff_file }++instance Binary ExtraFile where+    put (ExtraFile a b) = put (a,b)+    get = do+        (x,y) <- get+        return $ ExtraFile x y++instance Binary FieldMap where+    put (FieldMap ac ad) = do+	    putMap ac+	    putMap ad+    get = do+    ac <- getMap+    ad <- getMap+    return (FieldMap ac ad)++instance Data.Binary.Binary HoHeader where+    put (HoHeader aa ab ac ad ae) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+	    Data.Binary.put ae+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    ae <- get+    return (HoHeader aa ab ac ad ae)++instance Data.Binary.Binary HoIDeps where+    put (HoIDeps aa ab ac ad) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    return (HoIDeps aa ab ac ad)++instance Data.Binary.Binary HoLib where+    put (HoLib aa ab ac ad) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+	    Data.Binary.put ad+    get = do+    aa <- get+    ab <- get+    ac <- get+    ad <- get+    return (HoLib aa ab ac ad)++instance Binary Data.Version.Version where+    put (Data.Version.Version a b) = put a >> put b+    get = liftM2 Data.Version.Version get get++instance Data.Binary.Binary HoTcInfo where+    put (HoTcInfo aa ab ac ad ae af ag ah) = do+	    Data.Binary.put aa+	    putMap ab+	    putMap ac+	    Data.Binary.put ad+	    Data.Binary.put ae+	    Data.Binary.put af+	    Data.Binary.put ag+	    Data.Binary.put ah+    get = do+    aa <- get+    ab <- getMap+    ac <- getMap+    ad <- get+    ae <- get+    af <- get+    ag <- get+    ah <- get+    return (HoTcInfo aa ab ac ad ae af ag ah)++instance Data.Binary.Binary HoBuild where+    put (HoBuild aa ab ac) = do+	    Data.Binary.put aa+	    Data.Binary.put ab+	    Data.Binary.put ac+    get = do+    aa <- get+    ab <- get+    ac <- get+    return (HoBuild aa ab ac)
+ src/Ho/Collected.hs view
@@ -0,0 +1,73 @@+module Ho.Collected(+    CollectedHo(..),+    choDataTable,+    choClassHierarchy,+    choTypeSynonyms,+    choFixities,+    choAssumps,+    choRules,+    choEs,+    updateChoHo+    )where++import Control.Monad.Identity+import Data.List+import Data.Monoid++import DataConstructors+import E.Annotate+import E.E+import Ho.Type+import Info.Types+import Name.Name+import Util.SetLike+import qualified Data.Map as Map+import qualified Info.Info as Info++choDataTable = hoDataTable . hoBuild . choHo+choClassHierarchy = hoClassHierarchy . hoTcInfo . choHo+choTypeSynonyms = hoTypeSynonyms . hoTcInfo . choHo+choFixities = hoFixities . hoTcInfo . choHo+choAssumps = hoAssumps . hoTcInfo . choHo+choRules = hoRules . hoBuild . choHo+choEs cho = [ (combHead c,combBody c) | c <- values $  choCombinators cho]++instance Monoid CollectedHo where+    mempty = updateChoHo CollectedHo {+        choExternalNames = mempty,+        choOrphanRules = mempty,+        choHoMap = Map.singleton primModule pho,+        choCombinators = mempty,+        choHo = error "choHo-a",+        choVarMap = error "choVarMap-a",+        choLibDeps = mempty+        } where pho = mempty { hoBuild = mempty { hoDataTable = dataTablePrims } }+    a `mappend` b = updateChoHo CollectedHo {+        choExternalNames = choExternalNames a `mappend` choExternalNames b,+        choVarMap = error "choVarMap-b",+        choOrphanRules = choOrphanRules a `mappend` choOrphanRules b,+        choCombinators = choCombinators a `mergeChoCombinators` choCombinators b,+        choLibDeps = choLibDeps a `mappend` choLibDeps b,+        choHo = error "choHo-b",+        choHoMap = Map.union (choHoMap a) (choHoMap b)+        }++updateChoHo cho = cho { choHo = ho, choVarMap = varMap } where+    ho = hoBuild_u (hoEs_u f) . mconcat . Map.elems $ choHoMap cho+    f ds = runIdentity $ annotateDs mmap  (\_ -> return) (\_ -> return) (\_ -> return) (map g ds) where+        mmap = sfilter (\(k,_) -> (k `notElem` (map (tvrIdent . fst) ds))) varMap+    g (t,e) = case mlookup (tvrIdent t) varMap of+        Just (Just (EVar t')) -> (t',e)+        _ -> (t,e)+    varMap = fmap (\c -> Just (EVar $ combHead c)) $ choCombinators cho++-- this will have to merge rules and properties.+mergeChoCombinators :: IdMap Comb -> IdMap Comb -> IdMap Comb+mergeChoCombinators x y = unionWith f x y where+    f c1 c2 = combRules_s (combRules c1 `Data.List.union` combRules c2) . combHead_s (merge (combHead c1) (combHead c2)) $ c1+    merge ta tb = ta { tvrInfo = minfo' }   where+        minfo = tvrInfo ta `mappend` tvrInfo tb+        minfo' = dex (undefined :: Properties) $ minfo+        dex dummy y = g (Info.lookup (tvrInfo tb) `asTypeOf` Just dummy) where+            g Nothing = y+            g (Just x) = Info.insertWith mappend x y
+ src/Ho/Library.hs view
@@ -0,0 +1,262 @@+module Ho.Library(+    LibDesc(..),+    readDescFile,+    collectLibraries,+    libModMap,+    libHash,+    libMgHash,+    libProvides,+    libName,+    libBaseName,+    libHoLib,+    preprocess,+    listLibraries+    ) where++import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Version+import Data.Yaml.Syck+import System.Directory+import Text.Printf+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified System.FilePath as FP++import Ho.Binary+import Ho.ReadSource+import Ho.Type+import Name.Name(Module)+import Options+import PackedString(PackedString,packString,unpackPS)+import Util.Gen+import Util.YAML+import qualified FlagDump as FD+import qualified FlagOpts as FO+import qualified Support.MD5 as MD5++libModMap = hoModuleMap . libHoLib+libHash  = hohHash . libHoHeader+libMgHash mg lib = MD5.md5String $ show (libHash lib,mg)+libProvides mg lib = [ m | (m,mg') <- Map.toList (libModMap lib), mg == mg']+libName lib = let HoHeader { hohName = ~(Right (name,vers)) } = libHoHeader lib in unpackPS name ++ "-" ++ showVersion vers+libVersion lib = let HoHeader { hohName = ~(Right (_name,vers)) } = libHoHeader lib in vers+libBaseName lib = let HoHeader { hohName = ~(Right (name,_vers)) } = libHoHeader lib in name+libModules l = let lib = libHoLib l in ([ m | (m,_) <- Map.toList (hoModuleMap lib)],Map.toList (hoReexports lib))++libVersionCompare l1 l2 = compare (libVersion l1) (libVersion l2)++--------------------------------+-- finding and listing libraries+--------------------------------++instance ToNode Module where+    toNode m = toNode $ show m+instance ToNode HoHash where+    toNode m = toNode $ show m+instance ToNode PackedString where+    toNode m = toNode $ unpackPS m++listLibraries :: IO ()+listLibraries = do+    (_,byhashes) <- fetchAllLibraries+    let libs = Map.toList byhashes+    if not verbose then putStr $ showYAML (sort $ map (libName . snd) libs) else do+    let f (h,l) = (show h,[+            ("Name",toNode (libName l)),+            ("BaseName",toNode (libBaseName l)),+            ("Version",toNode (showVersion $ libVersion l)),+            ("FilePath",toNode (libFileName l)),+            ("LibDeps",toNode [ h | (_,h) <- hohLibDeps (libHoHeader l)]),+            ("Exported-Modules",toNode $ mod ++ fsts rmod)+            ]) where+          (mod,rmod) = libModules l+    putStr $ showYAML (map f libs)++-- Collect all libraries and return those which are explicitly and implicitly imported.+--+-- The basic process is:+--    - Find all libraries and create two indexes, a map of named libraries to+--      the newest version of them, and a map of library hashes to the libraries+--      themselves.+--+--    - For all the libraries listed on the command line, find the newest+--      version of each of them, flag these as the explicitly imported libraries.+--+--    - recursively find the dependencies by the hash's listed in the library deps. if the names+--      match a library already loaded, ensure the hash matches up. flag these libraries as 'implicit' unless+--      already flaged 'explicit'+--+--    - perform sanity checks on final lists of implicit and explicit libraries.+--+-- Library Checks needed:+--    - We have found versions of all libraries listed on the command line+--    - We have all dependencies of all libraries and the hash matches the proper library name+--    - no libraries directly export the same modules, (but re-exporting the same module is fine)+--    - conflicting versions of any particular library are not required due to dependencies++fetchAllLibraries :: IO (Map.Map PackedString [Library],Map.Map HoHash Library)+fetchAllLibraries = ans where+    ans = do+        (bynames',byhashes') <- unzip `fmap` concatMapM f (optHlPath options)+        let bynames = Map.map (reverse . sortBy libVersionCompare) $ Map.unionsWith (++) bynames'+            byhashes = Map.unions byhashes'+        return (bynames,byhashes)+    f fp = do+        fs <- flip iocatch (\_ -> return [] ) $ getDirectoryContents fp+        forM fs $ \e -> case reverse e of+            ('l':'h':'.':r)  -> flip iocatch (\_ -> return mempty) $ do+                lib <- readHlFile  (fp ++ "/" ++ e)+                return (Map.singleton (libBaseName lib) [lib], Map.singleton (libHash lib) lib)+            _               -> return mempty++splitOn' :: (a -> Bool) -> [a] -> [[a]]+splitOn' f xs = split xs+  where split xs = case break f xs of+          (chunk,[])     -> [chunk]+          (chunk,_:rest) -> chunk : split rest++splitVersion :: String -> (String,Data.Version.Version)+splitVersion s = ans where+    ans = case reverse (splitOn' ('-' ==) s) of+        (vrs:bs@(_:_)) | Just vrs <- runReadP parseVersion vrs -> (intercalate "-" (reverse bs),vrs)+        _ -> (s,Data.Version.Version [] [])++collectLibraries :: [String] -> IO ([Library],[Library])+collectLibraries libs = ans where+    ans = do+        (bynames,byhashes) <- fetchAllLibraries+        let f (pn,vrs) = lname pn vrs `mplus` lhash pn vrs where+                lname pn vrs = do+                    xs <- Map.lookup (packString pn) bynames+                    (x:_) <- return $ filter isGood xs+                    return x+                isGood lib = versionBranch vrs `isPrefixOf` versionBranch (libVersion lib)+                lhash pn vrs = do+                    [] <- return $ versionBranch vrs+                    Map.lookup pn byhashes'+            byhashes' = Map.fromList [ (show x,y) | (x,y) <- Map.toList byhashes]+        let es' = [ (x,f $ splitVersion x) | x <- libs ]+            es = [ l | (_,Just l) <- es' ]+            bad = [ n | (n,Nothing) <- es' ]+        unless (null bad) $ do+            putErrLn "Libraries not found:"+            forM_ bad $ \b -> putErrLn ("    " ++ b)+            exitFailure++        checkForModuleConficts es+        let f lmap _ [] = return lmap+            f lmap lset ((ei,l):ls)+                | libHash l `Set.member` lset = f lmap lset ls+                | otherwise = case Map.lookup (libBaseName l) lmap of+                    Nothing -> f (Map.insert (libBaseName l) (ei,l) lmap) (Set.insert (libHash l) lset) (ls ++ newdeps)+                    Just (ei',l') | libHash l == libHash l' -> f  (Map.insert (libBaseName l) (ei || ei',l) lmap) lset ls+                    Just (_,l')  -> putErrDie $ printf  "Conflicting versions of library '%s' are required. [%s]\n" (libName l) (show (libHash l,libHash l'))+              where newdeps = [ (False,fromMaybe (error $ printf "Dependency '%s' with hash '%s' needed by '%s' was not found" (unpackPS p) (show h) (libName l)) (Map.lookup h byhashes)) | let HoHeader { hohLibDeps = ldeps } = libHoHeader l , (p,h) <- ldeps ]+        finalmap <- f Map.empty Set.empty [ (True,l) | l <- es ]+        checkForModuleConficts [ l | (_,l) <- Map.elems finalmap ]+        when verbose $ forM_ (Map.toList finalmap) $ \ (n,(e,l)) ->+            printf "-- Base: %s Exported: %s Hash: %s Name: %s\n" (unpackPS n) (show e) (show $ libHash l) (libName l)++        return ([ l | (True,l) <- Map.elems finalmap ],[ l | (False,l) <- Map.elems finalmap ])++    checkForModuleConficts ms = do+        let mbad = Map.toList $ Map.filter (\c -> case c of [_] -> False; _ -> True)  $ Map.fromListWith (++) [ (m,[l]) | l <- ms, m <- fst $ libModules l]+        forM_ mbad $ \ (m,l) -> putErrLn $ printf "Module '%s' is exported by multiple libraries: %s" (show m) (show $ map libName l)+        unless (null mbad) $ putErrDie "There were conflicting modules!"++parseLibraryDescription :: Monad m => String -> m [(String,String)]+parseLibraryDescription fs =  g [] (lines (f [] fs)) where+    --f rs ('\n':s:xs) | isSpace s = f rs (dropWhile isSpace xs)+    f rs ('-':'-':xs) = f rs (dropWhile (/= '\n') xs)+    f rs ('{':'-':xs) = eatCom rs xs+    f rs (x:xs) = f (x:rs) xs+    f rs [] = reverse rs+    eatCom rs ('\n':xs) = eatCom ('\n':rs) xs+    eatCom rs ('-':'}':xs) = f rs xs+    eatCom rs (_:xs) = eatCom rs xs+    eatCom rs [] = f rs []+    g rs (s:ss) | all isSpace s = g rs ss+    g rs (s:s':ss) | all isSpace s' = g rs (s:ss)+    g rs (s:(h:cl):ss) | isSpace h = g rs ((s ++ h:cl):ss)+    g rs (r:ss) | (':':bd') <- bd = g ((map toLower $ condenseWhitespace nm,condenseWhitespace bd'):rs) ss+         | otherwise = fail $ "could not find ':' marker: " ++ show (rs,r:ss) where+            (nm,bd) = break (== ':') r+    g rs [] = return rs++condenseWhitespace xs =  reverse $ dropWhile isSpace (reverse (dropWhile isSpace (cw xs))) where+    cw (x:y:zs) | isSpace x && isSpace y = cw (' ':zs)+    cw (x:xs) = x:cw xs+    cw [] = []++procCabal :: [(String,String)] -> LibDesc+procCabal xs = f xs mempty mempty where+    f [] dlm dsm = LibDesc (combineAliases dlm) dsm+    f ((map toLower -> x,y):rs) dlm dsm | x `Set.member` list_fields = f rs (Map.insert x (spit y) dlm) dsm+                                        | otherwise = f rs dlm (Map.insert x y dsm)+    spit = words . map (\c -> if c == ',' then ' ' else c)++procYaml :: YamlNode -> LibDesc+procYaml MkNode { n_elem = EMap ms } = f ms mempty mempty where+    f [] dlm dsm = LibDesc (combineAliases dlm) dsm+    f ((n_elem -> EStr (map toLower . unpackBuf -> x),y):rs) dlm dsm = if x `Set.member` list_fields then dlist y else dsing y where+        dlist (n_elem -> EStr y)  = f rs (Map.insert x [unpackBuf y] dlm) dsm+        dlist (n_elem -> ESeq ss) = f rs (Map.insert x [ unpackBuf y | (n_elem -> EStr y) <- ss ] dlm) dsm+        dlist _ = f rs dlm dsm+        dsing (n_elem -> EStr y) = f rs dlm (Map.insert x (unpackBuf y) dsm)+        dsing _ = f rs dlm dsm+    f (_:xs) dlm dsm = f xs dlm dsm+procYaml _ = LibDesc mempty mempty++list_fields = Set.fromList $ [+    "exposed-modules",+    "include-dirs",+    "extensions",+    "options",+    "c-sources",+    "include-sources",+    "build-depends"+    ] ++ map fst alias_fields+      ++ map snd alias_fields++alias_fields = [+   ("other-modules","hidden-modules"),+   ("exported-modules","exposed-modules"),+   ("hs-source-dir","hs-source-dirs")+   ]++combineAliases mp = f alias_fields mp where+    f [] mp = mp+    f ((x,y):rs) mp = case Map.lookup x mp of+        Nothing -> f rs mp+        Just ys -> f rs $ Map.delete x $ Map.insertWith (++) y ys mp++data LibDesc = LibDesc (Map.Map String [String]) (Map.Map String String)++readDescFile :: FilePath -> IO LibDesc+readDescFile fp = do+    wdump FD.Progress $ putErrLn $ "Reading: " ++ show fp+    let doYaml opt = do+            lbs <- LBS.readFile fp+            dt <- preprocess opt fp lbs+            desc <- iocatch (parseYamlBytes $ BS.concat (LBS.toChunks dt))+                (\e -> putErrDie $ "Error parsing desc file '" ++ fp ++ "'\n" ++ show e)+            when verbose2 $ do+                yaml <- emitYaml desc+                putStrLn yaml+            return $ procYaml desc+        doCabal = do+            fc <- readFile fp+            case parseLibraryDescription fc of+                Left err -> fail $ "Error reading library description file: " ++ show fp ++ " " ++ err+                Right ps -> return $ procCabal ps+    case FP.splitExtension fp of+        (_,".cabal") -> doCabal+        (_,".yaml") -> doYaml options+        (FP.takeExtension -> ".yaml",".m4") -> doYaml options { optFOptsSet = FO.M4 `Set.insert` optFOptsSet options }+        _ -> putErrDie $ "Do not recoginize description file type: " ++ fp
+ src/Ho/ReadSource.hs view
@@ -0,0 +1,143 @@+-- routines dealing with reading and preprocessing source code files.+module Ho.ReadSource(+   preprocess,+   preprocessHs,+   languageFlags,+   fetchCompilerFlags,+   parseHsSource+) where++import Control.Monad+import Data.Char+import Data.Maybe+import System.FilePath as FP+import System.Process+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.UTF8 as LBSU+import qualified Data.Map as Map+import qualified Data.Set as Set++import FrontEnd.HsParser+import FrontEnd.HsSyn+import FrontEnd.ParseMonad+import FrontEnd.SrcLoc+import FrontEnd.Syn.Options+import FrontEnd.Unlit+import FrontEnd.Warning+import Options+import PackedString+import RawFiles(prelude_m4)+import Support.TempDir+import Util.FilterInput+import Util.Gen+import Version.Config(revision,version)+import qualified FlagDump as FD+import qualified FlagOpts as FO++preprocessHs :: Opt -> FilePath -> LBS.ByteString -> IO LBS.ByteString+preprocessHs options fn lbs = preprocess (fst $ collectFileOpts options fn (LBSU.toString $ LBS.take 2048 lbs)) fn lbs++preprocess :: Opt -> FilePath -> LBS.ByteString -> IO LBS.ByteString+preprocess opt fn lbs = do+    let fopts s = s `Set.member` optFOptsSet opt+        incFlags = [ "-I" ++ d | d <- optIncdirs opt ++ optIncs opt]+        defFlags = ("-D__JHC__=" ++ revision):("-D__JHC_VERSION__=" ++ version):[ "-D" ++ d | d <- optDefs opt]+    case () of+        _ | fopts FO.Cpp -> readSystem "cpp" $ ["-CC","-traditional"] ++ incFlags ++ defFlags ++ [fn]+          | fopts FO.M4  -> do+                m4p <- m4Prelude+                readSystem "m4" $ ["-s", "-P"] ++ incFlags ++ defFlags ++ [m4p,fn]+          | otherwise -> return lbs++m4Prelude :: IO FilePath+m4Prelude = fileInTempDir "prelude.m4" $ \fp -> do putStrLn $ "Writing stuff:" ++ fp ; BS.writeFile fp prelude_m4 ; return ()++collectFileOpts options fn s = (lproc opt,isJust fopts)  where+    copts os = [ as | (x,as) <- popts, x `elem` os]+    Just opt = fopts `mplus` Just options+    fopts = fileOptions options opts+    popts = parseOptions $ if FP.takeExtension fn == ".lhs" then unlit fn s else s+    opts = concatMap words (copts ["OPTIONS","JHC_OPTIONS","OPTIONS_JHC"])+    (pfs,nfs,_) = languageFlags $ concatMap (words . (map (\c -> if c == ',' then ' ' else c)))+        (copts ["LANGUAGE","JHC_LANGUAGE"] ++ optExtensions options ++ [ o | '-':'X':o <- opts])+    lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs }++-- translates a list of language extensions as pased to a LANGUAGE pragma or+-- the -X option to the equivalent '-f' flags. The first return value are the+-- positive flags, the negative flags, and the third is the unrecognized extensions.+languageFlags :: [String] -> (Set.Set FO.Flag,Set.Set FO.Flag,[String])+languageFlags ls = f ls Set.empty Set.empty [] where+    f [] pfs nfs us = (pfs,nfs,us)+    f (l:ls) pfs nfs us | Just lo <- Map.lookup ll langmap =  f ls (Set.union lo pfs) nfs us+                        | 'n':'o':ll <- ll, Just lo <- Map.lookup ll langmap = f ls pfs (nfs `Set.union` lo) us+                        | otherwise = f ls pfs nfs (l:us)+        where ll = map toLower l++langmap = Map.fromList [+    "m4" ==> FO.M4,+    "cpp" ==> FO.Cpp,+    "foreignfunctioninterface" ==> FO.Ffi,+    "implicitprelude" ==> FO.Prelude,+    "unboxedtuples" ==> FO.UnboxedTuples,+    "unboxedvalues" ==> FO.UnboxedValues,+    "monomorphismrestriction" ==> FO.MonomorphismRestriction,+    "explicitforall" ==> FO.Forall,+    "existentialquantification" =+> [FO.Forall,FO.Exists],+    "scopedtypevariables" ==> FO.Forall,+    "rankntypes" ==> FO.Forall,+    "rank2types" ==> FO.Forall,+    "bangpatterns" ==> FO.BangPatterns,+    "polymorphiccomponents" ==> FO.Forall,+    "TypeFamilies" ==> FO.TypeFamilies,+    "magichash" ==> FO.UnboxedValues+    ] where x ==> y = (x,Set.singleton y)+            x =+> y = (x,Set.fromList y)++parseHsSource :: Opt -> FilePath -> LBS.ByteString -> IO (HsModule,LBS.ByteString)+parseHsSource options fp@(FP.splitExtension -> (base,".hsc")) _ = do+    let out = FP.takeFileName base ++ ".hs"+    tdir <- getTempDir+    (cc,cflags) <- fetchCompilerFlags+    let incFlags = [ "-I" ++ d | d <- optIncdirs options ++ optIncs options]+        defFlags = [ "-D" ++ d | d <- optDefs options ]+    let hscargs =   [fp, "-o", tdir </> out] ++ defFlags ++ incFlags ++ concatMap (\x -> ["-C",x]) cflags ++ ["-c", cc]+    when verbose $+        print ("hsc2hs",hscargs)+    rawSystem "hsc2hs" hscargs+    print tdir+    print out+    lbs <- LBS.readFile $ tdir </> out+    parseHsSource options out lbs+parseHsSource options fn lbs = do+    lbs' <- preprocessHs options fn lbs+    let s = LBSU.toString lbs'+    let s' = if FP.takeExtension fn == ".lhs" then unlit fn s'' else s''+        s'' = case s of+            '#':' ':_   -> '\n':s                --  line pragma+            '#':'l':'i':'n':'e':' ':_  -> '\n':s --  line pragma+            '#':'!':_ -> dropWhile (/= '\n') s   --  hashbang+            _ -> s+    wdump FD.Preprocessed $ do+        putStrLn s'+    fn <- shortenPath fn+    let (fileOpts',ogood) = collectFileOpts options fn s+    unless ogood $+        warn (bogusASrcLoc { srcLocFileName = packString fn })+            UnknownOption "Invalid options in OPTIONS pragma"+    case runParserWithMode (parseModeOptions fileOpts') { parseFilename = fn } parse  s'  of+                      (ws,ParseOk e) -> processErrors ws >> return (e { hsModuleOpt = fileOpts' },LBSU.fromString s')+                      (_,ParseFailed sl err) -> putErrDie $ show sl ++ ": " ++ err++fetchCompilerFlags :: IO (FilePath,     -- ^ file path to compiler+                          [String])     -- ^ compiler arguments+fetchCompilerFlags = return (cc,args) where+    lup k = maybe "" id $ Map.lookup k (optInis options)+    boehmOpts | fopts FO.Boehm = ["-D_JHC_GC=_JHC_GC_BOEHM", "-lgc"]+              | fopts FO.Jgc   = ["-D_JHC_GC=_JHC_GC_JGC"]+              | otherwise = []+    profileOpts | fopts FO.Profile || lup "profile" == "true" = ["-D_JHC_PROFILE=1"]+                | otherwise = []+    debug = if fopts FO.Debug then words (lup "cflags_debug") else words (lup "cflags_nodebug")+    cc = lup "cc"+    args = words (lup "cflags") ++ debug ++ optCCargs options  ++ boehmOpts ++ profileOpts
+ src/Info/Binary.hs view
@@ -0,0 +1,75 @@+module Info.Binary(putInfo, Info.Binary.getInfo) where++import Data.Dynamic+import qualified Data.Map as Map++import C.FFI(FfiExport)+import Data.Binary+import E.CPR+import GenUtil+import Info.Info+import Info.Types+import Util.BitSet as BS+import qualified E.Demand++data Binable = forall a . (Typeable a, Binary a, Show a) => Binable a++u :: (Typeable a, Binary a) => a+u = u++newEntry x = Entry { entryThing = toDyn x, entryString = show x, entryType = typeOf x }++cb n x = (n, Binable x, typeOf x)++-- Note: the numbers here are part of the ABI of the serialized files.+-- If you change them then you must change the ABI version number in+-- Ho.Binary and invalidate all old files.+binTableValues =  [+    cb 1 (u :: Properties),+    cb 2 (u :: E.CPR.Val),+    cb 3 (u :: FfiExport),+    cb 4 (u :: E.Demand.DemandSignature)+    ]++binTable :: Map.Map Word8 Binable+binTable = Map.fromList [ (n,x) | (n,x,_) <- binTableValues ]++revBinTable :: [(TypeRep,(Word8,Binable))]+revBinTable = [ (t,(n,x)) | (n,x,t) <- binTableValues ]++putDyn :: (Word8,Dynamic,Binable) -> Put+putDyn (ps,d,Binable (_::a)) = do+    put ps+    put (fromDyn d (error (show d)) :: a)++getDyn = do+    (ps::Word8) <- get+    case Map.lookup ps binTable of+        Just (Binable (_ :: a)) -> do+            x <- get :: Get a+            return $ newEntry x+        Nothing -> fail $ "getDyn: don't know how to read something of type: " ++ show ps++instance Binary Properties where+    put (Properties (EBS props)) = put (fromIntegral $ BS.toWord props :: Word32)+    get = (get :: Get Word32) >>= return . Properties . EBS . BS.fromWord . fromIntegral++instance Binary Info where+    put nfo = putInfo nfo+    get = Info.Binary.getInfo++putInfo :: Info.Info.Info -> Put+putInfo (Info ds) = do+    let ds' = concatMap (\d -> do+            case Prelude.lookup (entryType d) revBinTable of+              Just (ps,x)  -> return (ps,entryThing d,x)+              Nothing -> fail "key not found"+          ) ds+    putWord8 (fromIntegral $ length ds')+    mapM_ putDyn ds'++getInfo :: Get Info.Info.Info+getInfo = do+    n <- getWord8+    xs <- replicateM (fromIntegral n) getDyn+    return (Info xs)
+ src/Info/Binary.hs-boot view
@@ -0,0 +1,7 @@+module Info.Binary where++import Info.Info+import Data.Binary++putInfo :: Info.Info.Info -> Put+getInfo :: Get Info.Info.Info
+ src/Info/Info.hs view
@@ -0,0 +1,154 @@+module Info.Info(+    T,+    Info(..),+    Entry(..),+    HasInfo(..),+    Info.Info.lookup,+    Info.Info.lookupTyp,+    insertWith,+    insert,+    limit,+    maybeInsert,+    singleton,+    member,+    delete,+    fetch,+    extend,+    empty,+    infoMap,+    infoMapM+    ) where++import Data.Dynamic+import Data.Monoid+import qualified Data.List as List++import GenUtil+import Util.HasSize++-- extensible type indexed product++type T = Info++data Entry = Entry {+    entryThing   :: Dynamic,+    entryString  :: String,+    entryType    :: !TypeRep+    }++instance Eq Entry where+    a == b = entryType a == entryType b++instance Show Entry where+    showsPrec _ x = showString (entryString x)++instance Ord Entry where+    compare a b = compare (show $ entryType a) (show $ entryType b)++newtype Info = Info [Entry]+    deriving(HasSize,Typeable)++-- the Eq and Ord instances for info make them all seem equivalent.+instance Eq Info where+    _ == _ = True+instance Ord Info where+    compare _ _ = EQ++instance Show Info where+    show (Info ds) = show (sortUnder (show . entryType) ds)++--instance Data Info where+--    toConstr = undefined+--    dataTypeOf = undefined++instance Monoid Info where+    mempty = empty+    mappend (Info as) (Info bs) = Info (List.union as bs)++class HasInfo a where+    getInfo :: a -> Info+    modifyInfo :: (Info -> Info) -> a -> a++instance HasInfo Info where+    getInfo = id+    modifyInfo f x = f x++lookupTyp :: forall a . Typeable a => a -> Info -> Maybe a+lookupTyp a = f where+    f (Info mp) = g mp+    typ = typeOf (undefined :: a)+    g [] = Nothing+    g (x:xs) | entryType x == typ = fromDynamic (entryThing x)+    g (_:xs) = g xs++lookup :: forall a m . (Monad m,Typeable a) => Info -> m a+lookup = maybe (fail $ "Info: could not find: " ++ show typ) return . f where+    typ = typeOf (undefined :: a)+    f = lookupTyp (undefined :: a)++insertWith :: (Show a,Typeable a) => (a -> a -> a) -> a -> Info -> Info+insertWith f newx (Info mp) = Info (g mp) where+    g [] = [newEntry newx]+    g (x:xs) | entryType x == typ = newEntry (f newx (fromDyn (entryThing x) (error "can't happen"))):xs+             | otherwise = x:g xs+    typ = typeOf newx++newEntry :: (Typeable a,Show a) => a -> Entry+newEntry x = Entry { entryThing = toDyn x, entryString = show x, entryType = typeOf x }++insert :: (Show a,Typeable a) => a -> Info -> Info+insert newx (Info nfo) = Info $ newEntry newx:f nfo where+    f [] = []+    f (x:xs) | entryType x == typ = xs+             | otherwise = x:f xs+    typ = typeOf newx++maybeInsert :: (Show a, Typeable a) => Maybe a -> Info -> Info+maybeInsert Nothing = id+maybeInsert (Just x) = insert x++singleton :: (Show a,Typeable a) => a -> Info+singleton x = insert x empty++infoMapM :: (Typeable a, Typeable b, Show b, Monad m) => (a -> m b) -> Info -> m Info+infoMapM f i = case Info.Info.lookup i of+    Just x -> do+        n <- f x+        return (insert n (delete x i))+    Nothing -> return i++infoMap :: (Typeable a, Typeable b, Show b) => (a -> b) -> Info ->  Info+infoMap f i = case Info.Info.lookup i of+    Just x -> insert (f x) (delete x i)+    Nothing -> i++delete :: (Typeable a) => a -> Info -> Info+delete x info = deleteTyp (typeOf x) info++deleteTyp :: TypeRep -> Info -> Info+deleteTyp typ (Info mp) = Info (f mp) where+    f [] = []+    f (x:xs) | entryType x == typ = xs+             | otherwise = x:f xs++limit :: [TypeRep] -> Info -> Info+limit trs (Info mp) = Info (f mp) where+    f (x:xs) | entryType x `elem` trs = x:f xs+             | otherwise = f xs+    f [] = []++fetch :: (Monoid a, Typeable a) => Info -> a+fetch info = maybe mempty id  (Info.Info.lookup info)++member :: (Typeable a) => a -> Info -> Bool+member x (Info s) = f s where+    typ = typeOf x+    f [] = False+    f (x:xs) | entryType x == typ = True+             | otherwise = f xs++extend :: (Show a,Monoid a, Typeable a) => a -> Info -> Info+extend x info = insertWith mappend x info++empty :: Info+empty = Info []
+ src/Info/Properties.hs view
@@ -0,0 +1,63 @@+module Info.Properties where++data Property = PROP_INLINE | PROP_MULTISPECIALIZE | PROP_NOINLINE | PROP_SRCLOC_ANNOTATE | PROP_SUPERINLINE | PROP_NOETA | PROP_CYCLIC | PROP_EXPORTED | PROP_INSTANCE | PROP_JOINPOINT | PROP_METHOD | PROP_ONESHOT | PROP_PLACEHOLDER | PROP_RULEBINDER | PROP_SCRUTINIZED | PROP_SPECIALIZATION | PROP_SRCLOC_ANNOTATE_FUN | PROP_SUPERSPECIALIZE | PROP_UNSHARED | PROP_WHNF | PROP_WORKER | PROP_WRAPPER | PROP_HASRULE+    deriving(Eq,Ord,Enum,Bounded)++instance Show Property where+   show PROP_INLINE = "INLINE"+   show PROP_MULTISPECIALIZE = "MULTISPECIALIZE"+   show PROP_NOINLINE = "NOINLINE"+   show PROP_SRCLOC_ANNOTATE = "SRCLOC_ANNOTATE"+   show PROP_SUPERINLINE = "SUPERINLINE"+   show PROP_NOETA = "NOETA"+   show PROP_CYCLIC = "_CYCLIC"+   show PROP_EXPORTED = "_EXPORTED"+   show PROP_INSTANCE = "_INSTANCE"+   show PROP_JOINPOINT = "_JOINPOINT"+   show PROP_METHOD = "_METHOD"+   show PROP_ONESHOT = "_ONESHOT"+   show PROP_PLACEHOLDER = "_PLACEHOLDER"+   show PROP_RULEBINDER = "_RULEBINDER"+   show PROP_SCRUTINIZED = "_SCRUTINIZED"+   show PROP_SPECIALIZATION = "_SPECIALIZATION"+   show PROP_SRCLOC_ANNOTATE_FUN = "_SRCLOC_ANNOTATE_FUN"+   show PROP_SUPERSPECIALIZE = "_SUPERSPECIALIZE"+   show PROP_UNSHARED = "_UNSHARED"+   show PROP_WHNF = "_WHNF"+   show PROP_WORKER = "_WORKER"+   show PROP_WRAPPER = "_WRAPPER"+   show PROP_HASRULE = "_HASRULE"+++{-# NOINLINE readProp #-}+readProp "INLINE" = return PROP_INLINE+readProp "MULTISPECIALIZE" = return PROP_MULTISPECIALIZE+readProp "NOINLINE" = return PROP_NOINLINE+readProp "SRCLOC_ANNOTATE" = return PROP_SRCLOC_ANNOTATE+readProp "SUPERINLINE" = return PROP_SUPERINLINE+readProp "NOETA" = return PROP_NOETA+readProp p = fail $ "Invalid Property: " ++ p++prop_INLINE = PROP_INLINE+prop_MULTISPECIALIZE = PROP_MULTISPECIALIZE+prop_NOINLINE = PROP_NOINLINE+prop_SRCLOC_ANNOTATE = PROP_SRCLOC_ANNOTATE+prop_SUPERINLINE = PROP_SUPERINLINE+prop_NOETA = PROP_NOETA+prop_CYCLIC = PROP_CYCLIC+prop_EXPORTED = PROP_EXPORTED+prop_INSTANCE = PROP_INSTANCE+prop_JOINPOINT = PROP_JOINPOINT+prop_METHOD = PROP_METHOD+prop_ONESHOT = PROP_ONESHOT+prop_PLACEHOLDER = PROP_PLACEHOLDER+prop_RULEBINDER = PROP_RULEBINDER+prop_SCRUTINIZED = PROP_SCRUTINIZED+prop_SPECIALIZATION = PROP_SPECIALIZATION+prop_SRCLOC_ANNOTATE_FUN = PROP_SRCLOC_ANNOTATE_FUN+prop_SUPERSPECIALIZE = PROP_SUPERSPECIALIZE+prop_UNSHARED = PROP_UNSHARED+prop_WHNF = PROP_WHNF+prop_WORKER = PROP_WORKER+prop_WRAPPER = PROP_WRAPPER+prop_HASRULE = PROP_HASRULE
+ src/Info/Types.hs view
@@ -0,0 +1,61 @@+-- | some useful types to use in Info's that don't really fit anywhere else+module Info.Types(module Info.Types, module Info.Properties) where++import Data.Dynamic+import Data.Monoid+import Info.Properties++import Util.BitSet+import Util.HasSize+import Util.SetLike+import qualified Info.Info as Info++-- | how many arguments a function my be applied to before it performs work and whether it bottoms out after that many arguments+data Arity = Arity Int Bool+    deriving(Typeable,Show,Ord,Eq)++-- | how the variable is bound+--data BindType = CaseDefault | CasePattern | LetBound | LambdaBound | PiBound+--    deriving(Show,Ord,Eq)++instance Show Properties where+    showsPrec _ props = shows (toList props)++-- | list of properties of a function, such as specified by use pragmas or options+newtype Properties = Properties (EnumBitSet Property)+    deriving(Typeable,Eq,Collection,SetLike,HasSize,Monoid,Unionize,IsEmpty)++type instance Elem Properties = Property+type instance Key Properties = Property++class HasProperties a where+    modifyProperties :: (Properties -> Properties) -> a -> a+    getProperties :: a -> Properties+    putProperties :: Properties -> a -> a++    setProperty :: Property -> a -> a+    unsetProperty :: Property -> a -> a+    getProperty :: Property -> a -> Bool+    setProperties :: [Property] -> a -> a++    unsetProperty prop = modifyProperties (delete prop)+    setProperty prop = modifyProperties (insert prop)+    setProperties xs = modifyProperties (`mappend` fromList xs)+    getProperty atom = member atom . getProperties++instance HasProperties Properties where+    getProperties prop = prop+    putProperties prop _ = prop+    modifyProperties f = f++fetchProperties :: Info.Info -> Maybe Properties+fetchProperties = Info.lookupTyp (undefined :: Properties)++instance HasProperties Info.Info where+    modifyProperties f info = case fetchProperties info of+        Just x -> Info.insert (f x) info+        Nothing -> Info.insert (f mempty) info+    getProperties info = case fetchProperties info of+        Just p -> p+        Nothing -> mempty+    putProperties prop info = Info.insert prop info
+ src/Interactive.hs view
@@ -0,0 +1,250 @@+module Interactive(Interactive.interact, isInteractive) where++import Control.Exception as CE+import Control.Monad.Identity+import Control.Monad.Reader+import Data.Monoid+import System.IO(stdout)+import System.Environment+import Data.List(sort,isPrefixOf)+import Data.Maybe+import Text.Regex+import qualified Data.Map as Map++import DataConstructors+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import FrontEnd.Desugar(desugarHsStmt)+import FrontEnd.HsParser(parseHsStmt)+import FrontEnd.HsPretty()+import FrontEnd.HsSyn+import FrontEnd.KindInfer+import FrontEnd.ParseMonad+import FrontEnd.Rename+import FrontEnd.Tc.Class+import FrontEnd.Tc.Main+import FrontEnd.Tc.Monad+import FrontEnd.Tc.Type+import FrontEnd.TypeSigs+import FrontEnd.TypeSynonyms(showSynonym)+import FrontEnd.TypeSyns+import FrontEnd.Warning+import GenUtil+import Ho.Type+import Name.Name+import Options+import Support.Compat+import Util.Interact+import Version.Version(versionString)+import qualified FrontEnd.HsPretty as HsPretty+import qualified FrontEnd.Infix+import qualified Text.PrettyPrint.HughesPJ as PP++printDoc doc = do+    displayIO stdout (renderPretty 0.9 80 doc)+    putStrLn ""++grep_opts = [+ "f - match normal value",+ "C - match data constructor",+ "T - match type constructor",+ "L - match class"+ ]++nameTag :: NameType -> Char+nameTag TypeConstructor = 'T'+nameTag DataConstructor = 'C'+nameTag ClassName = 'L'+nameTag Val = 'f'+nameTag _ = '?'++data InteractiveState = IS {+    stateHo :: HoTcInfo,+    stateInteract :: Interact,+    stateModule :: Module,+    stateImports :: [(Name,[Name])],+    stateOptions :: Opt+    }++isInitial = IS {+    stateHo = mempty,+    stateInteract = emptyInteract,+    stateModule = mainModule,+    stateImports = [],+    stateOptions = options+    }++newtype In a = MkIn (ReaderT InteractiveState IO a)+    deriving(MonadIO,Monad,Functor,MonadReader InteractiveState)++runIn :: InteractiveState -> In a -> IO a+runIn is (MkIn x) = runReaderT x is++instance OptionMonad In where+    getOptions = asks stateOptions++instance MonadWarn In where+    addWarning x = liftIO $ addWarning x++interact :: CollectedHo -> IO ()+interact cho = mre where+    hoE = hoTcInfo $ choHo cho+    hoB = hoBuild $ choHo cho++    mre = case optStmts options of+        [] -> go+        xs -> runInteractions initialInteract (concatMap lines $ reverse xs) >> exitSuccess+    go = do+        putStrLn "--------------------------------------------------------------"+        putStrLn "Welcome to the Ajhc interactive experience. use :help for help."+        putStrLn versionString+        putStrLn "(This is not a full interpreter, but rather is used to"+        putStrLn "help debug the compiler internals)"+        putStrLn "--------------------------------------------------------------"+        runInteraction initialInteract ":execfile ajhci.rc"+        beginInteraction initialInteract+    initialInteract = emptyInteract {+        interactSettables = ["prog", "args"],+        interactVersion = versionString,+        interactCommands = commands,+        interactWords = map (show . fst ) $ stateImports isStart,+        interactHistFile = Just ".ajhci-hist",+        interactComment = Just "--",+        interactExpr = do_expr+        }+    dataTable = hoDataTable hoB+    commands = [cmd_mods,cmd_grep]+    cmd_mods = InteractCommand { commandName = ":mods", commandHelp = "mods currently loaded modules", commandAction = do_mods }+    do_mods act _ _ = do+        printDoc $ fillSep (map tshow $ Map.keys $  hoExports hoE)+        return act+    cmd_grep = InteractCommand { commandName = ":grep", commandHelp = "show names matching a regex", commandAction = do_grep }+    do_grep act _ "" = do+        putStrLn ":grep [options] <regex>"+        putStrLn "Valid options:"+        putStr $ unlines grep_opts+        return act+    do_grep act _ arg = do+        let (opt,reg) = case simpleUnquote arg of+                [x] -> ("TCLf",x)+                xs -> f "" xs where+            f opt [x] = (opt,x)+            f opt ~(x:xs) = f (x ++ opt) xs+        rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException') -> return Nothing)+        case rx of+            Nothing -> putStrLn $ "Invalid regex: " ++ arg+            --Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v <+> "::" <+> ptype v  | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]+            Just rx -> mapM_ putStrLn $ sort [ pshow opt v  | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]+        return act+    ptype x | Just r <- pprintTypeOfCons dataTable x = r+    ptype k | Just r <- Map.lookup k (hoAssumps hoE) = show (pprint r:: PP.Doc)+    ptype x | nameType x == ClassName = hsep (map kindShow $ kindOfClass x (hoKinds hoE))+    ptype x = "UNKNOWN: " ++ show (nameType x,x)+    isStart =  isInitial { stateHo = hoE, stateImports = runIdentity $ calcImports hoE False preludeModule }+    do_expr :: Interact -> String -> IO Interact+    do_expr act s = case parseStmt (s ++ "\n") of+        Left m -> putStrLn m >> return act+        Right e -> do+            CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException'))+            return act+    pshow _opt v+        | Just d <- showSynonym (show . (pprint :: HsType -> PP.Doc) ) v (hoTypeSynonyms hoE) = nameTag (nameType v):' ':d+        | otherwise = nameTag (nameType v):' ':show v <+> "::" <+> ptype v++kindShow (KBase b) = pprint b+kindShow x = parens (pprint x)++parseStmt ::  Monad m => String -> m HsStmt+parseStmt s = case snd $ runParserWithMode (parseModeOptions options) { parseFilename = "(jhci)" } parseHsStmt  s  of+                      ParseOk e -> return e+                      ParseFailed sl err -> fail $ show sl ++ ": " ++ err++printStatement stmt = do+        liftIO $ putStrLn $ HsPretty.render $ HsPretty.ppHsStmt $  stmt++procErrors :: In a -> In ()+procErrors act = do+    b <- liftIO $ printIOErrors+    if b then return () else act >> return ()++executeStatement :: HsStmt -> In ()+executeStatement stmt = do+    is@IS { stateHo = hoE } <- ask+    stmt <- desugarHsStmt stmt+    stmt' <- renameStatement mempty (stateImports is) (stateModule is) stmt+    procErrors $ do+    --printStatement stmt'+    stmt'' <- expandTypeSynsStmt (hoTypeSynonyms hoE) (stateModule is) stmt'+    stmt''' <- return $ FrontEnd.Infix.infixStatement (hoFixities hoE) stmt''+    procErrors $ do+    printStatement stmt'''+    tcStatementTc stmt'''++{-+tcStatement :: HsStmt -> In ()+tcStatement HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"+tcStatement HsGenerator {} = liftIO $ putStrLn "generators not yet supported"+tcStatement (HsQualifier e) = do+    tcStatementTc (HsQualifier e)+    when False $ do+    is@IS { stateHo = ho } <- ask+    let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == Val ]+        importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x ==  DataConstructor ]+        ansName = Qual (stateModule is) (HsIdent "ans")+        ansName' = toName Val ansName+    opt <- getOptions+    localVarEnv <- liftIO $ TI.tiProgram+                opt                            -- options+                (stateModule is)               -- name of the module+                mempty                         -- environment of type signatures+                (hoKinds ho)                   -- kind information about classes and type constructors+                (hoClassHierarchy ho)          -- class hierarchy with instances+                importDConsEnv                 -- data constructor type environment+                importVarEnv                   -- type environment+                [([],[HsPatBind bogusASrcLoc (HsPVar ansName) (HsUnGuardedRhs e) []])]                        -- binding groups+                []+    procErrors $ do+    vv <- Map.lookup ansName' localVarEnv+    liftIO $ putStrLn $ show (text "::" <+> pprint vv :: P.Doc)+    -}++tcStatementTc :: HsStmt -> In ()+tcStatementTc HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"+tcStatementTc HsGenerator {} = liftIO $ putStrLn "generators not yet supported"+tcStatementTc (HsQualifier e) = do+    is@IS { stateHo = ho } <- ask+    let tcInfo = tcInfoEmpty {+        tcInfoEnv = (hoAssumps ho),+        tcInfoSigEnv =  collectSigEnv (hoKinds ho) (HsQualifier e),+        tcInfoModName =  (stateModule is),+        tcInfoKindInfo = (hoKinds ho),+        tcInfoClassHierarchy = (hoClassHierarchy ho)+        }+    runTc tcInfo $ do+    box <- newBox kindFunRet+    (_,ps') <- listenPreds $ tiExpr e box+    ps' <- flattenType ps'+    let ps = FrontEnd.Tc.Class.simplify (hoClassHierarchy ho) ps'+    (ps :=> vv) <- flattenType (ps :=> box)+    TForAll vs (ps :=> t) <- generalize ps vv -- quantify (tv vv) qt+    --liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)+    liftIO $ putStrLn $   "::" <+> prettyPrintType (TForAll vs (ps :=> t))+    ce <- getCollectedEnv+    liftIO $ mapM_ putStrLn [ pprint n <+>  "::" <+> prettyPrintType s |  (n,s) <- Map.toList ce]++calcImports :: Monad m => HoTcInfo -> Bool -> Module -> m [(Name,[Name])]+calcImports ho qual mod = case Map.lookup mod (hoExports ho) of+    Nothing -> fail $ "calcImports: module not known " ++ show mod+    Just es -> do+        let ls = sortGroupUnderFG fst snd+                [ (n,if qual then [setModule mod n] else [setModule mod n,toUnqualified n]) | n <- es]+            ls' = concat [ zip (concat nns) (repeat [n]) | (n,nns) <- ls ]+        return $ Map.toList $ Map.map snub $ Map.fromListWith (++) ls'++isInteractive :: IO Bool+isInteractive = do+    pn <- getProgName+    return $ (optMode options == Interactive)+          || "ichj" `isPrefixOf` reverse pn+          || not (null $ optStmts options)
+ src/Main.hs view
@@ -0,0 +1,116 @@+module Main(main) where++import Control.Exception+import Control.Monad.Identity+import Data.Char+import Prelude+import System.Directory+import System.FilePath as FP+import System.IO+import qualified Data.ByteString.Lazy as LBS++import DataConstructors+import E.Main+import E.Program+import E.Rules+import E.Type+import FrontEnd.Class+import Grin.Main(compileToGrin)+import Grin.Show(render)+import Ho.Build+import Ho.Collected+import Ho.Library+import Name.Name+import Options+import StringTable.Atom+import Support.TempDir+import Util.Gen+import Util.SetLike as S+import Version.Version(versionSimple)+import qualified FlagDump as FD+import qualified Interactive++main = wrapMain $ do+    hSetEncoding stdout utf8+    hSetEncoding stderr utf8+    o <- processOptions+    when (dump FD.Atom) $+        addAtExit dumpStringTableStats+    -- set temporary directory+    maybeDo $ do x <- optWorkDir o; return $ setTempDir x+    let darg = progressM $ do+        (argstring,_) <- getArgString+        return (argstring ++ "\n" ++ versionSimple)+    case optMode o of+        BuildHl hl    -> darg >> buildLibrary processInitialHo processDecls hl+        ListLibraries -> listLibraries+        ShowHo ho     -> dumpHoFile ho+        PurgeCache    -> purgeCache+        Preprocess    -> forM_ (optArgs o) $ \fn -> do+            lbs <- LBS.readFile fn+            res <- preprocessHs options fn lbs+            LBS.putStr res+        _               -> darg >> processFiles (optArgs o)++-- we are very careful to only delete cache files.+purgeCache = do+    Just hc <- findHoCache+    ds <- getDirectoryContents hc+    let cacheFile fn = case map toLower (reverse fn) of+            'o':'h':'.':fs -> length fs == 26 && all isAlphaNum fs+            _ -> False+    forM_ ds $ \fn -> when (cacheFile fn) (removeFile (hc </> fn))++processFiles :: [String] -> IO ()+processFiles cs = f cs (optMainFunc options) where+    f [] Nothing  = do+        int <- Interactive.isInteractive+        when (not int) $ putErrDie "ajhc: no input files"+        g [Left preludeModule]+    f [] (Just (b,m)) = do+        m <- getModule (parseName Val m)+        g [Left m]+    f cs _ = g (map fileOrModule cs)+    g fs = processCollectedHo . snd =<< parseFiles options [outputName] []+	    fs processInitialHo processDecls+    fileOrModule f = case reverse f of+        ('s':'h':'.':_)     -> Right f+        ('s':'h':'l':'.':_) -> Right f+        ('c':'s':'h':'.':_) -> Right f+        _                   -> Left $ toModule f++processCollectedHo cho = do+    if optStop options == CompileHo then return () else do+    putProgressLn "Collected Compilation..."++    when (dump FD.ClassSummary) $ do+        putStrLn "  ---- class summary ---- "+        printClassSummary (choClassHierarchy cho)+    when (dump FD.Class) $ do+        putStrLn "  ---- class hierarchy ---- "+        printClassHierarchy (choClassHierarchy cho)++    let dataTable = choDataTable cho+        combinators = values $ choCombinators cho++    evaluate dataTable+    evaluate combinators++    let prog = programUpdate program {+            progCombinators = combinators,+            progDataTable = dataTable+            }+    -- dump final version of various requested things+    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)+    wdump FD.DatatableBuiltin $+	putErrLn (render $ showDataTable samplePrimitiveDataTable)+    dumpRules (Rules $ fromList+	[(combIdent x,combRules x) | x <- combinators, not $ null (combRules x)])++    -- enter interactive mode+    int <- Interactive.isInteractive+    if int then Interactive.interact cho else do+        prog <- compileWholeProgram prog+        compileToGrin prog++progressM c  = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr
+ src/Name/Binary.hs view
@@ -0,0 +1,26 @@+module Name.Binary() where++import Data.Monoid+import Data.Maybe++import Data.Binary+import Name.Id+import Name.Name++instance Binary IdSet where+    put ids = do+        put [ id | id <- idSetToList ids, isNothing (fromId id)]+        put [ n | id <- idSetToList ids, n <- fromId id]+    get = do+        (idl:: [Id])   <- get+        (ndl:: [Name]) <- get+        return (idSetFromDistinctAscList idl `mappend` idSetFromList (map toId ndl))++instance Binary a => Binary (IdMap a) where+    put ids = do+        put [ x | x@(id,_) <- idMapToList ids, isNothing (fromId id)]+        put [ (n,v) | (id,v) <- idMapToList ids, n <- fromId id]+    get = do+        idl <- get+        ndl <- get+        return (idMapFromDistinctAscList idl `mappend` idMapFromList [ (toId n,v) | (n,v) <- ndl ])
+ src/Name/Id.hs view
@@ -0,0 +1,313 @@+module Name.Id(+    Id(),+    IdMap(),+    IdNameT(),+    IdSet(),+    anonymous,+    va1,va2,va3,va4,va5,+    addBoundNamesIdMap,+    addBoundNamesIdSet,+    addNamesIdSet,+    idMapToIdSet,+    anonymousIds,+    sillyId,+    etherealIds,+    isEtherealId,+    isInvalidId,+    isEmptyId,+    idSetToIdMap,+    mapMaybeIdMap,+    idSetFromList,+    idToInt,+    idSetFromDistinctAscList,+    idMapFromList,+    idMapFromDistinctAscList,+    idSetToList,+    idMapToList,+    emptyId,+    newIds,+    newId,+    mixInt,+    mixInt3,+    toId,+    fromId,+    candidateIds,+    runIdNameT+    )where++import Control.Monad.Reader+import Control.Monad.State+import Data.Bits+import Data.Int+import Data.Monoid+import qualified Data.Binary as B+import qualified Data.IntMap  as IM+import qualified Data.IntSet as IS++import Doc.DocLike+import Doc.PPrint+import Name.Name+import StringTable.Atom+import Util.HasSize+import Util.Inst()+import Util.NameMonad+import Util.SetLike as S++{-+ - An Id is an opaque type with equality and ordering, Its range is split into the following categories+ - all the following categories are disjoint.+ -+ - the unique empty id, called 'emptyId'+ -+ - for every Atom there is a unique cooresponding Id.+ -+ - a set of anonymous ids, indexed by positive numbers.+ -+ - a set of epheremal Ids presented as the list 'epheremalIds'. these are+ - generally used as placeholders for unification algorithms.+ -+ - In general, only atomic and anonymous ids are used as values, and the empty id is used to indicate+ - an usused binding site. epheremal and silly ids are used internally in certain algorithms and have no+ - meaning outside of said context. They never escape the code that uses them.+ -+ -}++newtype Id = Id Int+    deriving(Eq,Ord)++anonymous :: Int -> Id+anonymous x | x <= 0 = error "invalid anonymous id"+            | otherwise = Id (2*x)++-- | some convinience anonymous ids+va1,va2,va3,va4,va5 :: Id+va1  = anonymous 1+va2  = anonymous 2+va3  = anonymous 3+va4  = anonymous 4+va5  = anonymous 5++-- IdSet++instance Intjection Id where+    toIntjection i = (Id i)+    fromIntjection (Id i) = i++type IdSet = IntjectionSet Id+--type instance GSet Id = IdSet++{-+newtype IdSet = IdSet IS.IntSet+    deriving(Typeable,Monoid,HasSize,SetLike,IsEmpty,Eq,Ord)++instance BuildSet Id IdSet where+    fromList = idSetFromList+    fromDistinctAscList = idSetFromDistinctAscList+    insert (Id x) (IdSet b) = IdSet $ IS.insert x b+    singleton (Id x) = IdSet $ IS.singleton x++instance ModifySet Id IdSet where+    toList = idSetToList+    delete (Id x) (IdSet b) = IdSet $ IS.delete x b+    member (Id x) (IdSet b) = IS.member x b+    sfilter f (IdSet s) = IdSet $ IS.filter (f . Id) s++-}++idSetToList :: IdSet -> [Id]+idSetToList = S.toList++idMapToList :: IdMap a -> [(Id,a)]+idMapToList = S.toList++idToInt :: Id -> Int+idToInt (Id x) = x++mapMaybeIdMap :: (a -> Maybe b) -> IdMap a -> IdMap b+mapMaybeIdMap fn (IntjectionMap m) = IntjectionMap (IM.mapMaybe fn m)++type IdMap = IntjectionMap Id+--type instance GMap Id = IdMap++{-+newtype IdMap a = IdMap (IM.IntMap a)+    deriving(Typeable,Monoid,HasSize,SetLike,Functor,Traversable,Foldable,IsEmpty,Eq,Ord)++instance BuildSet (Id,a) (IdMap a) where+    fromList = idMapFromList+    fromDistinctAscList = idMapFromDistinctAscList+    insert (Id x,y) (IdMap b) = IdMap $ IM.insert x y b+    singleton (Id x,y) = IdMap $ IM.singleton x y++instance MapLike Id a (IdMap a) where+    melems (IdMap m) = IM.elems m+    mdelete (Id x) (IdMap m) = IdMap $ IM.delete x m+    mmember (Id x) (IdMap m) = IM.member x m+    mlookup (Id x) (IdMap m) = IM.lookup x m+    massocs (IdMap m) = [ (Id x,y) | (x,y) <- IM.assocs m ]+    mkeys (IdMap m) = [ Id x | x <- IM.keys m ]+    mmapWithKey f (IdMap m) = IdMap $ IM.mapWithKey (\k v -> f (Id k) v) m+    mfilter f (IdMap m) = IdMap $ IM.filter f m+    mpartitionWithKey f (IdMap m) = case IM.partitionWithKey (\k v -> f (Id k) v) m of (x,y) -> (IdMap x,IdMap y)+    munionWith f (IdMap m1) (IdMap m2) = IdMap $ IM.unionWith f m1 m2+    mfilterWithKey f (IdMap m) = IdMap $ IM.filterWithKey (\k v -> f (Id k) v) m++-}++--instance GMapSet Id where+--    toSet (IntjectionMap im)  = IntjectionSet $ IM.keysSet im+--    toMap f (IntjectionSet is) = IntjectionMap $ IM.fromDistinctAscList [ (x,f (Id x)) |  x <- IS.toAscList is]++--deriving instance MapLike Int a (IM.IntMap a) => MapLike Id a (IdMap a)++idSetToIdMap :: (Id -> a) -> IdSet -> IdMap a+--idSetToIdMap f (IdSet is) = IdMap $ IM.fromDistinctAscList [ (x,f (Id x)) |  x <- IS.toAscList is]+idSetToIdMap f (IntjectionSet is) = IntjectionMap $ IM.fromDistinctAscList [ (x,f (Id x)) |  x <- IS.toAscList is]++idMapToIdSet :: IdMap a -> IdSet+idMapToIdSet (IntjectionMap im)  = IntjectionSet $ IM.keysSet im+--idMapToIdSet (IdMap im) = IdSet $ (IM.keysSet im)++-- | Name monad transformer.+newtype IdNameT m a = IdNameT (StateT (IdSet, IdSet) m a)+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)++instance (MonadReader r m) => MonadReader r (IdNameT m) where+	ask       = lift ask+	local f (IdNameT m) = IdNameT $ local f m++-- | Run the name monad transformer.+runIdNameT :: (Monad m) => IdNameT m a -> m (a,IdSet)+runIdNameT (IdNameT x) = do+    (r,(used,bound)) <- runStateT x (mempty,mempty)+    return (r,bound)++fromIdNameT (IdNameT x) = x++instance Monad m => NameMonad Id (IdNameT m) where+    addNames ns = IdNameT $ do+        modify (\ (used,bound) -> (fromList ns `union` used, bound) )+    addBoundNames ns = IdNameT $ do+        let nset = fromList ns+        modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )+    uniqueName n = IdNameT $ do+        (used,bound) <- get+        if n `member` bound then fromIdNameT newName else put (insert n used,insert n bound) >> return n+    newNameFrom vs = IdNameT $ do+        (used,bound) <- get+        let f (x:xs)+                | x `member` used = f xs+                | otherwise = x+            f [] = error "newNameFrom: finite list!"+            nn = f vs+        put (insert nn used, insert nn bound)+        return nn+    newName  = IdNameT $ do+        (used,bound) <- get+        fromIdNameT $ newNameFrom (candidateIds (size used `mixInt` size bound))++addNamesIdSet nset = IdNameT $ do+    modify (\ (used,bound) -> (nset `union` used, bound) )+addBoundNamesIdSet nset = IdNameT $ do+    modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )++addBoundNamesIdMap nmap = IdNameT $ do+    modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where+        nset = idMapToIdSet nmap++idSetFromDistinctAscList :: [Id] -> IdSet+idSetFromDistinctAscList ids = IntjectionSet (IS.fromDistinctAscList [ x | Id x <- ids] )++idSetFromList :: [Id] -> IdSet+idSetFromList ids = fromList ids++idMapFromList :: [(Id,a)] -> IdMap a+idMapFromList ids = fromList  ids++idMapFromDistinctAscList :: [(Id,a)] -> IdMap a+idMapFromDistinctAscList ids = IntjectionMap (IM.fromDistinctAscList [ (x,y) | (Id x,y) <- ids ] )++instance Show Id where+        showsPrec _ (Id 0) =  showChar '_'+        showsPrec _ (Id x) =  maybe (showString ('x':show (x `div` 2))) shows (fromId $ Id x)++instance Show IdSet where+    showsPrec n is = showsPrec n (idSetToList is)++instance Show v => Show (IdMap v) where+    showsPrec n is = showsPrec n (idMapToList is)++anonymousIds :: [Id]+anonymousIds = map anonymous [1 .. ]++etherealIds :: [Id]+etherealIds = map Id [-4, -6 ..  ]++isEmptyId x = x == emptyId+isEtherealId id = id < emptyId++-- | id isn't anonymous or atom-mapped+isInvalidId id = id <= emptyId++-- | A occasionally useful random ethereal id+sillyId :: Id+sillyId = Id $ -2++emptyId :: Id+emptyId = Id 0++-- | find some temporary ids that are not members of the set,+-- useful for generating a small number of local unique names.++newIds :: IdSet -> [Id]+newIds (IntjectionSet ids) = ans where+    ans = if sids == 0 then candidateIds 42 else [ Id i | Id i <- candidates, i `notMember` ids ]+    sids = size ids+    candidates = candidateIds (mixInt3 sids (IS.findMin ids) (IS.findMax ids))++newId :: Int           -- ^ a seed value, useful for speeding up finding a unique id+      -> (Id -> Bool)  -- ^ whether an Id is acceptable+      -> Id            -- ^ your new Id+newId seed check = head $ filter check (candidateIds seed)++-- generate a list of candidate anonymous ids based on a seed value+candidateIds :: Int -> [Id]+candidateIds !seed = f (2 + (mask $ hashInt seed)) where+    mask x = x .&. 0x0FFFFFFE+    f !x = Id x:f (x + 2)+    --mask x = trace ("candidate " ++ show seed) $ Id $ x .&. 0x0FFFFFFE++toId :: Name -> Id+toId x = Id $ fromAtom (toAtom x)++instance FromAtom Id where+    fromAtom x = Id $ fromAtom x++fromId :: Monad m => Id -> m Name+fromId (Id i) = case intToAtom i of+    Just a -> return $ fromAtom a+    Nothing -> fail $ "Name.fromId: not a name " ++ show (Id i)++instance DocLike d => PPrint d Id where+    pprint x = tshow x++instance GenName Id where+    genNames = candidateIds++instance B.Binary Id where+    put (Id x) = case intToAtom x of+        Just a -> do B.putWord8 128 >> B.put a+        Nothing | x >= 0 && x < 128 -> B.putWord8 (fromIntegral x)+                | otherwise -> do+                    B.putWord8 129+                    B.put (fromIntegral x :: Int32)+    get = do+        x <- B.getWord8+        case x of+            128 -> do+                a <- B.get+                return (toId $ fromAtom a)+            129 -> do+                v <- B.get+                return (Id $ fromIntegral (v :: Int32))+            _ -> return (Id $ fromIntegral x)
+ src/Name/Name.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+module Name.Name(+    Module(..),+    Name,+    Class,+    NameType(..),+    ToName(..),+    ffiExportName,+    fromModule,+    fromTypishHsName,+    fromValishHsName,+    getIdent,+    getModule,+    isConstructorLike,+    isTypeNamespace,+    isValNamespace,+    mainModule,+    preludeModule,+    mapName,+    mapName',+    nameName,+    nameParts,+    nameType,+    parseName,+    primModule,+    qualifyName,+    setModule,+    quoteName,+    fromQuotedName,+    toModule,+    toUnqualified+    ) where++import Data.Char+import Data.Data++import C.FFI+import Data.Binary+import Doc.DocLike+import Doc.PPrint+import GenUtil+import StringTable.Atom++-------------+-- Name types+-------------++data NameType+    = TypeConstructor+    | DataConstructor+    | ClassName+    | TypeVal+    | Val+    | SortName+    | FieldLabel+    | RawType+    | UnknownType+    | QuotedName+    deriving(Ord,Eq,Enum,Read,Show)++isTypeNamespace TypeConstructor = True+isTypeNamespace ClassName = True+isTypeNamespace TypeVal = True+isTypeNamespace _ = False++isValNamespace DataConstructor = True+isValNamespace Val = True+isValNamespace _ = False++-----------------+-- name definiton+-----------------++newtype Name = Name Atom+    deriving(Ord,Eq,Typeable,Binary,Data,ToAtom,FromAtom)++isConstructorLike n =  isUpper x || x `elem` ":("  || xs == "->" || xs == "[]" where+    (_,_,xs@(x:_)) = nameParts n++fromTypishHsName, fromValishHsName :: Name -> Name+fromTypishHsName name+    | nameType name == QuotedName = name+    | isConstructorLike name = toName TypeConstructor name+    | otherwise = toName TypeVal name+fromValishHsName name+    | nameType name == QuotedName = name+    | isConstructorLike name = toName DataConstructor name+    | otherwise = toName Val name++createName :: NameType -> Module -> String -> Name+createName _ (Module "") i = error $ "createName: empty module " ++ i+createName _ m "" = error $ "createName: empty ident " ++ show m+createName t m i = Name $ toAtom $ (chr $ ord '1' + fromEnum t):show m ++ ";" ++ i++createUName :: NameType -> String -> Name+createUName _ "" = error $ "createUName: empty ident"+createUName t i =  Name $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i++class ToName a where+    toName :: NameType -> a -> Name+    fromName :: Name -> (NameType, a)++instance ToName (String,String) where+    toName nt (m,i) = createName nt (Module $ toAtom m) i+    fromName n = case nameParts n of+            (nt,Just (Module m),i) -> (nt,(show m,i))+            (nt,Nothing,i) -> (nt,("",i))++instance ToName (Module,String) where+    toName nt (m,i) = createName nt m i+    fromName n = case nameParts n of+            (nt,Just m,i) -> (nt,(m,i))+            (nt,Nothing,i) -> (nt,(Module "",i))++instance ToName (Maybe Module,String) where+    toName nt (Just m,i) = createName nt m i+    toName nt (Nothing,i) = createUName nt i+    fromName n = case nameParts n of+        (nt,a,b) -> (nt,(a,b))++instance ToName Name where+    toName nt i = toName nt (x,y) where+        (_,x,y) = nameParts i+    fromName n = (nameType n,n)++instance ToName String where+    toName nt i = createUName nt i+    fromName n = (nameType n, mi ) where+        mi = case snd $ fromName n of+            (Just (Module m),i) -> show m ++ "." ++ i+            (Nothing,i) -> i++getModule :: Monad m => Name -> m Module+getModule n = case nameParts n of+    (_,Just m,_) -> return m+    _ -> fail "Name is unqualified."++getIdent :: Name -> String+getIdent n = case nameParts n of+    (_,_,s)  -> s++toUnqualified :: Name -> Name+toUnqualified n = case nameParts n of+    (_,Nothing,_) -> n+    (t,Just _,i) -> toName t (Nothing :: Maybe Module,i)++qualifyName :: Module -> Name -> Name+qualifyName m n = case nameParts n of+    (t,Nothing,n) -> toName t (Just m, n)+    _ -> n++setModule :: Module -> Name -> Name+setModule m n = qualifyName m  $ toUnqualified n++parseName :: NameType -> String -> Name+parseName t name = toName t (intercalate "." ms, intercalate "." (ns ++ [last sn])) where+    sn = (split (== '.') name)+    (ms,ns) = span validMod (init sn)+    validMod (c:cs) = isUpper c && all (\c -> isAlphaNum c || c `elem` "_'") cs+    validMod _ = False++nameType :: Name -> NameType+nameType (Name a) = toEnum $ fromIntegral ( a `unsafeByteIndex` 0) - ord '1'++nameName :: Name -> Name+nameName n = n++nameParts :: Name -> (NameType,Maybe Module,String)+nameParts n@(Name a) = f $ tail (fromAtom a) where+    f (';':xs) = (nameType n,Nothing,xs)+    f xs = (nameType n,Just $ Module (toAtom a),b) where+        (a,_:b) = span (/= ';') xs++instance Show Name where+    showsPrec _ n = case nameParts n of+        (QuotedName,Nothing,b) -> showChar '`' . showString b+        (_,Just a,b) -> shows a . showChar '.' . showString b+        (_,Nothing,b) -> showString b++instance DocLike d => PPrint d Name  where+    pprint n = text (show n)++mapName :: (Module -> Module,String -> String) -> Name -> Name+mapName (f,g) n = case nameParts n of+    (nt,Nothing,i) -> toName nt (g i)+    (nt,Just m,i) -> toName nt (Just (f m :: Module),g i)+mapName' :: (Maybe Module -> Maybe Module) -> (String -> String) -> Name -> Name+mapName' f g n = case nameParts n of+    (nt,m,i) -> toName nt (f m,g i)++ffiExportName :: FfiExport -> Name+ffiExportName (FfiExport cn _ cc _ _) = toName Val (Module "FE@", show cc ++ "." ++ cn)+type Class = Name++-------------+-- Quoting+-------------++quoteName :: Name -> Name+quoteName (Name n) = createUName QuotedName (fromAtom n)+fromQuotedName :: Name -> Maybe Name+fromQuotedName n = case nameParts n of+    (QuotedName,Nothing,s) -> Just $ Name (toAtom s)+    _ -> Nothing++--------------+-- Modules+--------------++newtype Module = Module Atom+  deriving(Eq,Data,Typeable,ToAtom,FromAtom)++instance Ord Module where+    compare x y = show x `compare` show y++instance Show Module where+    showsPrec _ (Module n) = shows n++fromModule (Module s) = fromAtom s++mainModule = Module "Main@"+primModule = Module "Prim@"+preludeModule = Module "Prelude"++toModule :: String -> Module+toModule s = Module $ toAtom s
+ src/Name/Names.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+-- | All hardcoded names in the compiler should go in here+-- the convention is+-- v_foo for values+-- tc_foo for type constructors+-- dc_foo for data constructors+-- s_foo for sort names+-- rt_foo for raw names+-- class_foo for classes++module Name.Names(module Name.Names,module Name.Prim) where++import Data.Char(isDigit)++import Name.Name+import Name.Prim+import Name.VConsts++instance TypeNames Name where+    tInt = tc_Int+    tBool = tc_Bool+    tInteger = tc_Integer+    tChar = tc_Char+    tUnit = tc_Unit++    tIntzh = rt_bits32+    tEnumzh = rt_bits16+    tCharzh = tc_Char_+--    tWorld__ = tc_World__++--No tuple instance because it is easy to get the namespace wrong. use 'nameTuple'+--instance ToTuple Name where+--    toTuple n = toName DataConstructor (toTuple n :: (String,String))++nameTuple _ n | n < 2 = error "attempt to create tuple of length < 2"+nameTuple t n = toName t  $ (toTuple n:: (String,String)) -- Qual (HsIdent ("(" ++ replicate (n - 1) ',' ++ ")"))++unboxedNameTuple t n = toName t $ "(#" ++ show n ++ "#)"+fromUnboxedNameTuple n = case show n of+    '(':'#':xs | (ns@(_:_),"#)") <- span isDigit xs -> return (read ns::Int)+    _ -> fail $ "Not unboxed tuple: " ++ show n++instance FromTupname Name where+    fromTupname name | m == Module "Jhc.Prim.Prim" = fromTupname (nn::String) where+        (_,(m,nn)) = fromName name+    fromTupname _ = fail "not a tuple"++-- quasi-kinds (placeholders for existential kinds)+s_Quest = toName SortName (Module "Jhc@","?"::String)+s_QuestQuest = toName SortName (Module "Jhc@","??"::String)+s_StarBang = toName SortName (Module "Jhc@","*!"::String)+s_Any = toName SortName (Module "Jhc@","ANY"::String)++u_instance = toName UnknownType (Module "Jhc@","instance"::String)++sFuncNames = FuncNames {+    func_equals = v_equals,+    func_fromInteger = v_fromInteger,+    func_fromInt = v_fromInt,+    func_fromRational = v_fromRational,+    func_negate = v_negate,+    func_runExpr = v_runExpr,+    func_runMain = v_runMain,+    func_runNoWrapper = v_runNoWrapper,+    func_runRaw = v_runRaw+    }
+ src/Name/Prim.hs view
@@ -0,0 +1,301 @@+{- WARNING! Do not edit!!!+   This code is autogenerated from src/data/*.txt! -}++{-# Language NoOverloadedStrings #-}+module Name.Prim where++import Name.Name+++{-# NOINLINE tc_IOErrorType #-}+tc_IOErrorType = toName TypeConstructor ("Jhc.Type.Handle","IOErrorType")+{-# NOINLINE tc_IOMode #-}+tc_IOMode = toName TypeConstructor ("Jhc.Type.Handle","IOMode")+{-# NOINLINE tc_Bang_ #-}+tc_Bang_ = toName TypeConstructor ("Jhc.Prim.Rts","Bang_")+{-# NOINLINE tc_Arrow #-}+tc_Arrow = toName TypeConstructor ("Jhc.Prim.Prim","->")+{-# NOINLINE tc_MutArray__ #-}+tc_MutArray__ = toName TypeConstructor ("Jhc.Prim.Array","MutArray_")+{-# NOINLINE tc_List #-}+tc_List = toName TypeConstructor ("Jhc.Prim.Prim","[]")+{-# NOINLINE tc_Char #-}+tc_Char = toName TypeConstructor ("Jhc.Type.Basic","Char")+{-# NOINLINE tc_IO #-}+tc_IO = toName TypeConstructor ("Jhc.Prim.IO","IO")+{-# NOINLINE tc_ST #-}+tc_ST = toName TypeConstructor ("Jhc.Prim.IO","ST")+{-# NOINLINE tc_ACIO #-}+tc_ACIO = toName TypeConstructor ("Jhc.Prim.IO","ACIO")+{-# NOINLINE tc_State_ #-}+tc_State_ = toName TypeConstructor ("Jhc.Prim.IO","State_")+{-# NOINLINE tc_RealWorld #-}+tc_RealWorld = toName TypeConstructor ("Jhc.Prim.IO","RealWorld")+{-# NOINLINE tc_Bool #-}+tc_Bool = toName TypeConstructor ("Jhc.Prim.Prim","Bool")+{-# NOINLINE tc_Ordering #-}+tc_Ordering = toName TypeConstructor ("Jhc.Prim.Prim","Ordering")+{-# NOINLINE tc_Bool_ #-}+tc_Bool_ = toName TypeConstructor ("Jhc.Prim.Bits","Bool_")+{-# NOINLINE tc_Unit #-}+tc_Unit = toName TypeConstructor ("Jhc.Prim.Prim","()")+{-# NOINLINE tc_Ratio #-}+tc_Ratio = toName TypeConstructor ("Jhc.Type.Float","Ratio")+{-# NOINLINE tc_Float #-}+tc_Float = toName TypeConstructor ("Jhc.Type.Float","Float")+{-# NOINLINE tc_Double #-}+tc_Double = toName TypeConstructor ("Jhc.Type.Float","Double")+{-# NOINLINE tc_Ptr #-}+tc_Ptr = toName TypeConstructor ("Jhc.Type.Ptr","Ptr")+{-# NOINLINE tc_FunPtr #-}+tc_FunPtr = toName TypeConstructor ("Jhc.Type.Ptr","FunPtr")+{-# NOINLINE tc_Integer #-}+tc_Integer = toName TypeConstructor ("Jhc.Type.Basic","Integer")+{-# NOINLINE tc_Int #-}+tc_Int = toName TypeConstructor ("Jhc.Type.Word","Int")+{-# NOINLINE tc_Bits1 #-}+tc_Bits1 = toName TypeConstructor ("Jhc.Prim.Bits","Bits1_")+{-# NOINLINE tc_Bits8 #-}+tc_Bits8 = toName TypeConstructor ("Jhc.Prim.Bits","Bits8_")+{-# NOINLINE tc_Bits16 #-}+tc_Bits16 = toName TypeConstructor ("Jhc.Prim.Bits","Bits16_")+{-# NOINLINE tc_Bits32 #-}+tc_Bits32 = toName TypeConstructor ("Jhc.Prim.Bits","Bits32_")+{-# NOINLINE tc_Bits64 #-}+tc_Bits64 = toName TypeConstructor ("Jhc.Prim.Bits","Bits64_")+{-# NOINLINE tc_Bits128 #-}+tc_Bits128 = toName TypeConstructor ("Jhc.Prim.Bits","Bits128_")+{-# NOINLINE tc_BitsPtr #-}+tc_BitsPtr = toName TypeConstructor ("Jhc.Prim.Bits","BitsPtr_")+{-# NOINLINE tc_BitsMax #-}+tc_BitsMax = toName TypeConstructor ("Jhc.Prim.Bits","BitsMax_")+{-# NOINLINE tc_Float32 #-}+tc_Float32 = toName TypeConstructor ("Jhc.Prim.Bits","Float32_")+{-# NOINLINE tc_Float64 #-}+tc_Float64 = toName TypeConstructor ("Jhc.Prim.Bits","Float64_")+{-# NOINLINE tc_Float80 #-}+tc_Float80 = toName TypeConstructor ("Jhc.Prim.Bits","Float80_")+{-# NOINLINE tc_Float128 #-}+tc_Float128 = toName TypeConstructor ("Jhc.Prim.Bits","Float128_")+{-# NOINLINE tc_Complex #-}+tc_Complex = toName TypeConstructor ("Jhc.Prim.Bits","Complex_")+{-# NOINLINE tc_Addr_ #-}+tc_Addr_ = toName TypeConstructor ("Jhc.Prim.Bits","Addr_")+{-# NOINLINE tc_FunAddr_ #-}+tc_FunAddr_ = toName TypeConstructor ("Jhc.Prim.Bits","FunAddr_")+{-# NOINLINE tc_Char_ #-}+tc_Char_ = toName TypeConstructor ("Jhc.Prim.Bits","Char_")+{-# NOINLINE dc_Boolzh #-}+dc_Boolzh = toName DataConstructor ("Jhc.Prim.Prim","Bool#")+{-# NOINLINE dc_Char #-}+dc_Char = toName DataConstructor ("Jhc.Type.Basic","Char")+{-# NOINLINE dc_Cons #-}+dc_Cons = toName DataConstructor ("Jhc.Prim.Prim",":")+{-# NOINLINE dc_EmptyList #-}+dc_EmptyList = toName DataConstructor ("Jhc.Prim.Prim","[]")+{-# NOINLINE dc_Int #-}+dc_Int = toName DataConstructor ("Jhc.Type.Word","Int")+{-# NOINLINE dc_Integer #-}+dc_Integer = toName DataConstructor ("Jhc.Type.Basic","Integer")+{-# NOINLINE dc_Ratio #-}+dc_Ratio = toName DataConstructor ("Jhc.Type.Float",":%")+{-# NOINLINE dc_Unit #-}+dc_Unit = toName DataConstructor ("Jhc.Prim.Prim","()")+{-# NOINLINE dc_Pair #-}+dc_Pair = toName DataConstructor ("Jhc.Prim.Prim","(,)")+{-# NOINLINE dc_Word #-}+dc_Word = toName DataConstructor ("Jhc.Type.Word","Word")+{-# NOINLINE dc_True #-}+dc_True = toName DataConstructor ("Jhc.Prim.Prim","True")+{-# NOINLINE dc_False #-}+dc_False = toName DataConstructor ("Jhc.Prim.Prim","True")+{-# NOINLINE dc_EQ #-}+dc_EQ = toName DataConstructor ("Jhc.Prim.Prim","EQ")+{-# NOINLINE class_Eq #-}+class_Eq = toName ClassName ("Jhc.Class.Ord","Eq")+{-# NOINLINE class_Ord #-}+class_Ord = toName ClassName ("Jhc.Class.Ord","Ord")+{-# NOINLINE class_Enum #-}+class_Enum = toName ClassName ("Jhc.Enum","Enum")+{-# NOINLINE class_Bounded #-}+class_Bounded = toName ClassName ("Jhc.Enum","Bounded")+{-# NOINLINE class_Show #-}+class_Show = toName ClassName ("Jhc.Show","Show")+{-# NOINLINE class_Read #-}+class_Read = toName ClassName ("Jhc.Text.Read","Read")+{-# NOINLINE class_Ix #-}+class_Ix = toName ClassName ("Data.Ix","Ix")+{-# NOINLINE class_Functor #-}+class_Functor = toName ClassName ("Jhc.Monad","Functor")+{-# NOINLINE class_Monad #-}+class_Monad = toName ClassName ("Jhc.Monad","Monad")+{-# NOINLINE class_Num #-}+class_Num = toName ClassName ("Jhc.Class.Num","Num")+{-# NOINLINE class_Real #-}+class_Real = toName ClassName ("Jhc.Class.Real","Real")+{-# NOINLINE class_Integral #-}+class_Integral = toName ClassName ("Jhc.Class.Real","Integral")+{-# NOINLINE class_Fractional #-}+class_Fractional = toName ClassName ("Jhc.Class.Real","Fractional")+{-# NOINLINE class_Floating #-}+class_Floating = toName ClassName ("Jhc.Float","Floating")+{-# NOINLINE class_RealFrac #-}+class_RealFrac = toName ClassName ("Jhc.Float","RealFrac")+{-# NOINLINE class_RealFloat #-}+class_RealFloat = toName ClassName ("Jhc.Float","RealFloat")+{-# NOINLINE rt_bits8 #-}+rt_bits8 = toName RawType "bits8"+{-# NOINLINE rt_bits16 #-}+rt_bits16 = toName RawType "bits16"+{-# NOINLINE rt_bits32 #-}+rt_bits32 = toName RawType "bits32"+{-# NOINLINE rt_bits64 #-}+rt_bits64 = toName RawType "bits64"+{-# NOINLINE rt_bits128 #-}+rt_bits128 = toName RawType "bits128"+{-# NOINLINE rt_bool #-}+rt_bool = toName RawType "bool"+{-# NOINLINE rt_float32 #-}+rt_float32 = toName RawType "fbits32"+{-# NOINLINE rt_float64 #-}+rt_float64 = toName RawType "fbits64"+{-# NOINLINE rt_float80 #-}+rt_float80 = toName RawType "fbits80"+{-# NOINLINE rt_float128 #-}+rt_float128 = toName RawType "fbits128"+{-# NOINLINE rt_bits_max_ #-}+rt_bits_max_ = toName RawType "bits<max>"+{-# NOINLINE rt_bits_ptr_ #-}+rt_bits_ptr_ = toName RawType "bits<ptr>"+{-# NOINLINE v_eqString #-}+v_eqString = toName Val ("Jhc.String","eqString")+{-# NOINLINE v_eqUnpackedString #-}+v_eqUnpackedString = toName Val ("Jhc.String","eqUnpackedString")+{-# NOINLINE v_error #-}+v_error = toName Val ("Jhc.IO","error")+{-# NOINLINE v_map #-}+v_map = toName Val ("Jhc.Basics","map")+{-# NOINLINE v_and #-}+v_and = toName Val ("Jhc.Order","&&")+{-# NOINLINE v_foldr #-}+v_foldr = toName Val ("Jhc.Basics","foldr")+{-# NOINLINE v_foldl #-}+v_foldl = toName Val ("Jhc.Basics","foldl")+{-# NOINLINE v_drop #-}+v_drop = toName Val ("Jhc.List","drop")+{-# NOINLINE v_cat #-}+v_cat = toName Val ("Jhc.Basics","++")+{-# NOINLINE v_compose #-}+v_compose = toName Val ("Jhc.Basics",".")+{-# NOINLINE v_bind #-}+v_bind = toName Val ("Jhc.Monad",">>=")+{-# NOINLINE v_bind_ #-}+v_bind_ = toName Val ("Jhc.Monad",">>")+{-# NOINLINE v_fail #-}+v_fail = toName Val ("Jhc.Monad","fail")+{-# NOINLINE v_concatMap #-}+v_concatMap = toName Val ("Jhc.Basics","concatMap")+{-# NOINLINE v_fromInteger #-}+v_fromInteger = toName Val ("Jhc.Class.Num","fromInteger")+{-# NOINLINE v_fromInt #-}+v_fromInt = toName Val ("Jhc.Class.Num","fromInt")+{-# NOINLINE v_sub #-}+v_sub = toName Val ("Jhc.Class.Num","-")+{-# NOINLINE v_fromRational #-}+v_fromRational = toName Val ("Jhc.Class.Real","fromRational")+{-# NOINLINE v_negate #-}+v_negate = toName Val ("Jhc.Class.Num","negate")+{-# NOINLINE v_compare #-}+v_compare = toName Val ("Jhc.Class.Ord","compare")+{-# NOINLINE v_leq #-}+v_leq = toName Val ("Jhc.Class.Ord","<=")+{-# NOINLINE v_geq #-}+v_geq = toName Val ("Jhc.Class.Ord",">=")+{-# NOINLINE v_lt #-}+v_lt = toName Val ("Jhc.Class.Ord","<")+{-# NOINLINE v_gt #-}+v_gt = toName Val ("Jhc.Class.Ord",">")+{-# NOINLINE v_equals #-}+v_equals = toName Val ("Jhc.Class.Ord","==")+{-# NOINLINE v_fromEnum #-}+v_fromEnum = toName Val ("Jhc.Enum","fromEnum")+{-# NOINLINE v_toEnum #-}+v_toEnum = toName Val ("Jhc.Enum","toEnum")+{-# NOINLINE v_enumFrom #-}+v_enumFrom = toName Val ("Jhc.Enum","enumFrom")+{-# NOINLINE v_enumFromTo #-}+v_enumFromTo = toName Val ("Jhc.Enum","enumFromTo")+{-# NOINLINE v_enumFromThenTo #-}+v_enumFromThenTo = toName Val ("Jhc.Enum","enumFromThenTo")+{-# NOINLINE v_enumFromThen #-}+v_enumFromThen = toName Val ("Jhc.Enum","enumFromThen")+{-# NOINLINE v_succ #-}+v_succ = toName Val ("Jhc.Enum","succ")+{-# NOINLINE v_pred #-}+v_pred = toName Val ("Jhc.Enum","pred")+{-# NOINLINE v_minBound #-}+v_minBound = toName Val ("Jhc.Enum","minBound")+{-# NOINLINE v_maxBound #-}+v_maxBound = toName Val ("Jhc.Enum","maxBound")+{-# NOINLINE v_showsPrec #-}+v_showsPrec = toName Val ("Jhc.Show","showsPrec")+{-# NOINLINE v_showParen #-}+v_showParen = toName Val ("Jhc.Show","showParen")+{-# NOINLINE v_showChar #-}+v_showChar = toName Val ("Jhc.Show","showChar")+{-# NOINLINE v_showString #-}+v_showString = toName Val ("Jhc.Show","showString")+{-# NOINLINE v_readsPrec #-}+v_readsPrec = toName Val ("Jhc.Text.Read","readsPrec")+{-# NOINLINE v_readParen #-}+v_readParen = toName Val ("Jhc.Text.Read","readParen")+{-# NOINLINE v_lex #-}+v_lex = toName Val ("Jhc.Text.Read","lex")+{-# NOINLINE v_range #-}+v_range = toName Val ("Data.Ix","range")+{-# NOINLINE v_index #-}+v_index = toName Val ("Data.Ix","index")+{-# NOINLINE v_inRange #-}+v_inRange = toName Val ("Data.Ix","inRange")+{-# NOINLINE v_runExpr #-}+v_runExpr = toName Val ("Prelude.IO","runExpr")+{-# NOINLINE v_runRaw #-}+v_runRaw = toName Val ("Jhc.Prim.Wrapper","runRaw")+{-# NOINLINE v_runMain #-}+v_runMain = toName Val ("Jhc.IO","runMain")+{-# NOINLINE v_runNoWrapper #-}+v_runNoWrapper = toName Val ("Jhc.Prim.Wrapper","runNoWrapper")+{-# NOINLINE v_enum_succ #-}+v_enum_succ = toName Val ("Jhc.Inst.PrimEnum","enum_succ")+{-# NOINLINE v_enum_pred #-}+v_enum_pred = toName Val ("Jhc.Inst.PrimEnum","enum_pred")+{-# NOINLINE v_enum_from #-}+v_enum_from = toName Val ("Jhc.Inst.PrimEnum","enum_from")+{-# NOINLINE v_enum_fromTo #-}+v_enum_fromTo = toName Val ("Jhc.Inst.PrimEnum","enum_fromTo")+{-# NOINLINE v_enum_fromThen #-}+v_enum_fromThen = toName Val ("Jhc.Inst.PrimEnum","enum_fromThen")+{-# NOINLINE v_enum_fromThenTo #-}+v_enum_fromThenTo = toName Val ("Jhc.Inst.PrimEnum","enum_fromThenTo")+{-# NOINLINE v_enum_toEnum #-}+v_enum_toEnum = toName Val ("Jhc.Inst.PrimEnum","enum_toEnum")+{-# NOINLINE v_ix_index #-}+v_ix_index = toName Val ("Jhc.Inst.PrimEnum","ix_index")+{-# NOINLINE v_ix_inRange #-}+v_ix_inRange = toName Val ("Jhc.Inst.PrimEnum","ix_inRange")+{-# NOINLINE v_ix_range #-}+v_ix_range = toName Val ("Jhc.Inst.PrimEnum","ix_range")+{-# NOINLINE s_Star #-}+s_Star = toName SortName ("Jhc@","*")+{-# NOINLINE s_Hash #-}+s_Hash = toName SortName ("Jhc@","#")+{-# NOINLINE s_Bang #-}+s_Bang = toName SortName ("Jhc@","!")+{-# NOINLINE s_Tuple #-}+s_Tuple = toName SortName ("Jhc@","(#)")+{-# NOINLINE s_HashHash #-}+s_HashHash = toName SortName ("Jhc@","##")+{-# NOINLINE s_StarStar #-}+s_StarStar = toName SortName ("Jhc@","**")++
+ src/PackedString.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module PackedString (+    PackedString,+    packString,+    unpackPS,+    ) where++import Data.Binary+import Data.Generics+import Data.Monoid+import GHC.Exts+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as BSU++newtype PackedString = PS BS.ByteString+    deriving(Typeable,Binary,Eq,Ord,Monoid,Data)++instance Show PackedString where+    showsPrec p ps r = showsPrec p (unpackPS ps) r++-- | Convert a 'String' into a 'PackedString'+packString :: String -> PackedString+packString str = PS (BSU.fromString str)++unpackPS :: PackedString -> String+unpackPS (PS bs) = BSU.toString bs++instance IsString PackedString where+    fromString = packString
+ src/RawFiles.hs view
@@ -0,0 +1,4063 @@+module RawFiles where++import Data.ByteString.Unsafe+import Data.ByteString+import System.IO.Unsafe++-- | Generated from src\/data\/ViaGhc.hs+{-# NOINLINE viaghc_hs #-}+viaghc_hs :: ByteString+viaghc_hs = unsafePerformIO $ unsafePackAddress "\+ \{-# OPTIONS_GHC -fglasgow-exts -fno-implicit-prelude #-}\n\+ \module Main(main) where\n\+ \\n\+ \import GHC.Int\n\+ \import GHC.Word\n\+ \import GHC.IOBase\n\+ \import GHC.Prim\n\+ \import GHC.Base\n\+ \import GHC.Ptr\n\+ \import GHC.Err\n\+ \\n\+ \type World__ = State# RealWorld\n\+ \type Array__ a = Array# a\n\+ \type MutArray__ a = MutableArray# RealWorld a\n\+ \type Ref__ a = MutVar# RealWorld a\n\+ \\n\+ \type Nothing = ()\n\+ \\n\+ \theNothing :: Nothing\n\+ \theNothing = ()\n\+ \\n\+ \type JIO a = World__ -> (# World__, a #)\n\+ \\n\+ \main :: IO ()\n\+ \main = IO $ \\rw -> case theRealMain rw of rw' -> (# rw', () #)\n\+ \\n\+ \unPtr :: Ptr a -> Addr#\n\+ \unPtr ptr = case ptr of\n\+ \    Ptr addr -> addr\n\+ \\n\+ \unFunPtr :: FunPtr a -> Addr#\n\+ \unFunPtr ptr = case ptr of\n\+ \    FunPtr addr -> addr\n\+ \\n\+ \fromBool :: Bool -> Int#\n\+ \fromBool b = case b of\n\+ \    False -> 0#\n\+ \    True -> 1#\n\+ \\n\+ \gteChar# a b = gtChar# a b || eqChar# a b\n\+ \lteChar# a b = ltChar# a b || eqChar# a b\n\+ \\n\+ \plusAddr__ :: Addr# -> Addr# -> Addr#\n\+ \plusAddr__ a1 a2 = plusAddr# a1 (addr2Int# a2)\n\+ \\n\+ \alloca__ :: Int# -> (Addr# -> JIO a) -> JIO a\n\+ \alloca__ size action s =\n\+ \     case newPinnedByteArray# size s      of { (# s, mbarr# #) ->\n\+ \     case unsafeFreezeByteArray# mbarr# s of { (# s, barr#  #) ->\n\+ \     case action (byteArrayContents# barr#) s of { (# s, r #) ->\n\+ \     case touch# barr# s of { s -> (# s, r #) }\n\+ \     }}}\n\+ \\n\+ \word2Char__ x = chr# (word2Int# x)\n\+ \char2Word__ x = int2Word# (ord# x)\n\+ \addr2Word__ x = int2Word# (addr2Int# x)\n\+ \word2Addr__ x = int2Addr# (word2Int# x)\n\+ \\n\+ \convertString :: [Char] -> ListTCon Char\n\+ \convertString [] = jhc_EmptyList\n\+ \convertString (x:xs) = jhc_Cons x (convertString xs)\n\+ \\n\+ \{-\n\+ \error__ :: Addr# -> a\n\+ \error__ s = unsafePerformIO $ do\n\+ \    error_show s\n\+ \    error_exit (I# 255#)\n\+ \\n\+ \errorInt__ :: Addr# -> Int#\n\+ \errorInt__ s = seq (unsafePerformIO $ do\n\+ \    error_show s\n\+ \    error_exit (I# 255#)) 0#\n\+ \\n\+ \errorWord__ :: Addr# -> Word#\n\+ \errorWord__ s = seq (unsafePerformIO $ do\n\+ \    error_show s\n\+ \    error_exit (I# 255#)) (int2Word# 0#)\n\+ \\n\+ \errorAddr__ :: Addr# -> Addr#\n\+ \errorAddr__ s = seq (unsafePerformIO $ do\n\+ \    error_show s\n\+ \    error_exit (I# 255#)) (int2Addr# 0#)\n\+ \foreign import ccall unsafe \"puts\" error_show :: Ptr a -> IO ()\n\+ \foreign import ccall unsafe \"exit\" error_exit :: Int -> IO a\n\+ \ -}\n\+ \\n\+ \{-# NOINLINE newWorld__ #-}\n\+ \newWorld__ :: a -> World__\n\+ \newWorld__ a = case lazy a of\n\+ \    _ -> realWorld#\n\+ \\n\+ \theRealMain :: World__ -> World__\n\+ \\n\+ \"#++-- | Generated from src\/data\/prelude.m4+{-# NOINLINE prelude_m4 #-}+prelude_m4 :: ByteString+prelude_m4 = unsafePerformIO $ unsafePackAddress "\+ \m4_changequote({{,}})\n\+ \m4_changecom({-,-})\n\+ \\n\+ \m4_define(ONCE,{{m4_ifdef(done-$1,{{m4_dnl}},{{m4_define(done-$1,1)$1}})}})\n\+ \\n\+ \m4_define({{m4_for}},{{m4_ifelse($#,0,{{{{$0}}}},{{m4_ifelse(m4_eval($2<=$3),1,\n\+ \{{m4_pushdef({{$1}},$2)$4{{}}m4_popdef({{$1}})$0({{$1}},m4_incr($2),$3,{{$4}})}})}})}})\n\+ \\n\+ \m4_define({{m4_foreach}},{{m4_ifelse(m4_eval($#>2),1,\n\+ \{{m4_pushdef({{$1}},{{$3}})$2{{}}m4_popdef({{$1}})m4_dnl\n\+ \{{}}m4_ifelse(m4_eval($#>3),1,{{$0({{$1}},{{$2}},m4_shift(m4_shift(m4_shift($@))))}})}})}})\n\+ \"#++-- | Generated from src\/data\/targets.ini+{-# NOINLINE targets_ini #-}+targets_ini :: ByteString+targets_ini = unsafePerformIO $ unsafePackAddress "\+ \;\n\+ \; configuration file for architectures and compiler options.\n\+ \;\n\+ \; the final value set is the one used.\n\+ \;\n\+ \; all '-m' parameters on the command line are parsed and processed in order.\n\+ \;\n\+ \; there is an implicit -mdefault processed first\n\+ \; entries in the user config file are appended to this one.\n\+ \;\n\+ \; the cross compilation entries in this file should be treated as examples.\n\+ \; although they work out of the box for many systems, cross compilation\n\+ \; environments differ, so you may need to override them for your\n\+ \; specific setup.\n\+ \\n\+ \[default]\n\+ \cc=gcc\n\+ \gc=jgc\n\+ \cflags=-std=gnu99 -D_GNU_SOURCE -falign-functions=4 -ffast-math -Wextra -Wall -Wno-unused-parameter -fno-strict-aliasing\n\+ \cflags_debug=-g\n\+ \cflags_nodebug=-DNDEBUG -O3\n\+ \profile=false\n\+ \autoload=haskell2010,haskell-extras,haskell98\n\+ \\n\+ \\n\+ \; cross compilation entries\n\+ \\n\+ \[win32]\n\+ \cc=i386-mingw32-gcc\n\+ \executable_extension=.exe\n\+ \merge=i686\n\+ \\n\+ \[wii]\n\+ \cc=powerpc-eabi-gcc\n\+ \byteorder=be\n\+ \cflags+=-g -DGEKKO -D__WORDSIZE=32 -mrvl -mcpu=750 -meabi -mhard-float\n\+ \executable_extension=.elf\n\+ \bits=32\n\+ \bits_max=64\n\+ \merge=be32\n\+ \\n\+ \; macintosh, this is for cross compiling, not for native compilation on osx\n\+ \[osx]\n\+ \\n\+ \[osx-intel]\n\+ \cc=i686-apple-darwin9-gcc\n\+ \merge=i686\n\+ \merge=osx\n\+ \\n\+ \[osx-powerpc]\n\+ \cc=powerpc-apple-darwin9-gcc\n\+ \merge=be32\n\+ \merge=osx\n\+ \\n\+ \; a couple specific cpus\n\+ \[i686]\n\+ \merge=le32\n\+ \arch=i686\n\+ \bits_max=64\n\+ \cflags_nodebug+=-fomit-frame-pointer\n\+ \\n\+ \[x86_64]\n\+ \bits_max=64\n\+ \merge=le64\n\+ \\n\+ \[le32]\n\+ \\n\+ \byteorder=le\n\+ \merge=32\n\+ \\n\+ \[be32]\n\+ \byteorder=be\n\+ \merge=32\n\+ \\n\+ \[le64]\n\+ \byteorder=le\n\+ \merge=64\n\+ \\n\+ \[be64]\n\+ \byteorder=be\n\+ \merge=64\n\+ \\n\+ \[32]\n\+ \cflags+=-m32\n\+ \bits=32\n\+ \\n\+ \[64]\n\+ \cflags+=-m64\n\+ \bits=64\n\+ \\n\+ \"#++-- | Generated from rts\/rts\/constants.h+{-# NOINLINE constants_h #-}+constants_h :: ByteString+constants_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef RTS_CONSTANTS_H\n\+ \#define RTS_CONSTANTS_H\n\+ \/* these constants are shared between jhc-prim and the rts. */\n\+ \\n\+ \// Normal memory block.\n\+ \#define SLAB_FLAG_NONE         0\n\+ \\n\+ \// Each element has a finalizer-list as its second word.\n\+ \#define SLAB_FLAG_FINALIZER    1\n\+ \\n\+ \// In addition to whatever other finalization is done, 'free' should be called\n\+ \// on the first word of each entry.\n\+ \#define SLAB_FLAG_FREE         2\n\+ \\n\+ \// Finalizers should be delayed until entire slab is freed up and individually\n\+ \// freed members need not be kept track of.\n\+ \#define SLAB_FLAG_DELAY        4\n\+ \\n\+ \// A global finalizer exists for this slab\n\+ \#define SLAB_GLOBAL_FINALIZER  8\n\+ \\n\+ \// slab is a monolith, should be 'free'd when done with and not returned to\n\+ \// cache.\n\+ \#define SLAB_MONOLITH          16\n\+ \\n\+ \// virtual flags are never set in a cache but are used internally to keep track\n\+ \// of things.\n\+ \\n\+ \// virtual flag to indicate location is a value\n\+ \#define SLAB_VIRTUAL_VALUE     256\n\+ \\n\+ \// virtual flag to indicate location has a special intererpretation.\n\+ \#define SLAB_VIRTUAL_SPECIAL   512\n\+ \\n\+ \// virtual flag to indication location is a constant.\n\+ \#define SLAB_VIRTUAL_CONSTANT  1024\n\+ \\n\+ \// virtual flag to indication location has been freed. (for debugging)\n\+ \#define SLAB_VIRTUAL_FREED     2048\n\+ \\n\+ \// virtual flag to indication location is lazy.\n\+ \#define SLAB_VIRTUAL_LAZY      4096\n\+ \\n\+ \// virtual flag to indication location is func.\n\+ \#define SLAB_VIRTUAL_FUNC      8192\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/stableptr.c+{-# NOINLINE stableptr_c #-}+stableptr_c :: ByteString+stableptr_c = unsafePerformIO $ unsafePackAddress "\+ \#include \"sys/queue.h\"\n\+ \#include \"jhc_rts_header.h\"\n\+ \\n\+ \struct StablePtr_list root_StablePtrs = LIST_HEAD_INITIALIZER();\n\+ \\n\+ \wptr_t c_newStablePtr(sptr_t c) {\n\+ \    struct StablePtr* sp = malloc(sizeof(struct StablePtr));\n\+ \    sp->contents = c;\n\+ \    LIST_INSERT_HEAD(&root_StablePtrs, sp, link);\n\+ \    assert(GET_PTYPE(sp) == 0);\n\+ \    return (wptr_t)TO_SPTR(P_VALUE,(wptr_t)sp);\n\+ \}\n\+ \\n\+ \void c_freeStablePtr(wptr_t wp) {\n\+ \    struct StablePtr *sp = FROM_SPTR((HsPtr)wp);\n\+ \    LIST_REMOVE(sp, link);\n\+ \    free(sp);\n\+ \}\n\+ \\n\+ \sptr_t c_derefStablePtr(wptr_t wp) {\n\+ \    struct StablePtr *sp = FROM_SPTR((HsPtr)wp);\n\+ \    return sp->contents;\n\+ \}\n\+ \\n\+ \void hs_free_stable_ptr(HsStablePtr sp) {\n\+ \        c_freeStablePtr((HsStablePtr)sp);\n\+ \}\n\+ \void hs_free_fun_ptr(HsFunPtr fp) {}\n\+ \\n\+ \/*\n\+ \wptr_t c_castPtrToStablePtr(void *)\n\+ \void * c_castStablePtrToPtr(wptr_t)\n\+ \*/\n\+ \"#++-- | Generated from rts\/sys\/queue.h+{-# NOINLINE queue_h #-}+queue_h :: ByteString+queue_h = unsafePerformIO $ unsafePackAddress "\+ \/*\n\+ \ * Copyright (c) 1991, 1993\n\+ \ *\x0009\&The Regents of the University of California.  All rights reserved.\n\+ \ *\n\+ \ * Redistribution and use in source and binary forms, with or without\n\+ \ * modification, are permitted provided that the following conditions\n\+ \ * are met:\n\+ \ * 1. Redistributions of source code must retain the above copyright\n\+ \ *    notice, this list of conditions and the following disclaimer.\n\+ \ * 2. Redistributions in binary form must reproduce the above copyright\n\+ \ *    notice, this list of conditions and the following disclaimer in the\n\+ \ *    documentation and/or other materials provided with the distribution.\n\+ \ * 3. Neither the name of the University nor the names of its contributors\n\+ \ *    may be used to endorse or promote products derived from this software\n\+ \ *    without specific prior written permission.\n\+ \ *\n\+ \ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND\n\+ \ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n\+ \ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\n\+ \ * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE\n\+ \ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\n\+ \ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS\n\+ \ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)\n\+ \ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\n\+ \ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\n\+ \ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF\n\+ \ * SUCH DAMAGE.\n\+ \ *\n\+ \ *\x0009\&@(#)queue.h\x0009\&8.5 (Berkeley) 8/20/94\n\+ \ */\n\+ \\n\+ \#ifndef\x0009\&_SYS_QUEUE_H_\n\+ \#define\x0009\&_SYS_QUEUE_H_\n\+ \\n\+ \/*\n\+ \ * This file defines five types of data structures: singly-linked lists,\n\+ \ * lists, simple queues, tail queues, and circular queues.\n\+ \ *\n\+ \ * A singly-linked list is headed by a single forward pointer. The\n\+ \ * elements are singly linked for minimum space and pointer manipulation\n\+ \ * overhead at the expense of O(n) removal for arbitrary elements. New\n\+ \ * elements can be added to the list after an existing element or at the\n\+ \ * head of the list.  Elements being removed from the head of the list\n\+ \ * should use the explicit macro for this purpose for optimum\n\+ \ * efficiency. A singly-linked list may only be traversed in the forward\n\+ \ * direction.  Singly-linked lists are ideal for applications with large\n\+ \ * datasets and few or no removals or for implementing a LIFO queue.\n\+ \ *\n\+ \ * A list is headed by a single forward pointer (or an array of forward\n\+ \ * pointers for a hash table header). The elements are doubly linked\n\+ \ * so that an arbitrary element can be removed without a need to\n\+ \ * traverse the list. New elements can be added to the list before\n\+ \ * or after an existing element or at the head of the list. A list\n\+ \ * may only be traversed in the forward direction.\n\+ \ *\n\+ \ * A simple queue is headed by a pair of pointers, one the head of the\n\+ \ * list and the other to the tail of the list. The elements are singly\n\+ \ * linked to save space, so elements can only be removed from the\n\+ \ * head of the list. New elements can be added to the list after\n\+ \ * an existing element, at the head of the list, or at the end of the\n\+ \ * list. A simple queue may only be traversed in the forward direction.\n\+ \ *\n\+ \ * A tail queue is headed by a pair of pointers, one to the head of the\n\+ \ * list and the other to the tail of the list. The elements are doubly\n\+ \ * linked so that an arbitrary element can be removed without a need to\n\+ \ * traverse the list. New elements can be added to the list before or\n\+ \ * after an existing element, at the head of the list, or at the end of\n\+ \ * the list. A tail queue may be traversed in either direction.\n\+ \ *\n\+ \ * A circle queue is headed by a pair of pointers, one to the head of the\n\+ \ * list and the other to the tail of the list. The elements are doubly\n\+ \ * linked so that an arbitrary element can be removed without a need to\n\+ \ * traverse the list. New elements can be added to the list before or after\n\+ \ * an existing element, at the head of the list, or at the end of the list.\n\+ \ * A circle queue may be traversed in either direction, but has a more\n\+ \ * complex end of list detection.\n\+ \ *\n\+ \ * For details on the use of these macros, see the queue(3) manual page.\n\+ \ */\n\+ \\n\+ \/*\n\+ \ * List definitions.\n\+ \ */\n\+ \#define\x0009\&LIST_HEAD(name, type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct name {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *lh_first;\x0009\&/* first element */\x0009\&\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \#define\x0009\&LIST_HEAD_INITIALIZER(head)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&{ NULL }\n\+ \\n\+ \#define\x0009\&LIST_ENTRY(type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *le_next;\x0009\&/* next element */\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type **le_prev;\x0009\&/* address of previous next element */\x0009\&\\\n\+ \}\n\+ \\n\+ \/*\n\+ \ * List functions.\n\+ \ */\n\+ \#define\x0009\&LIST_INIT(head) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->lh_first = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&LIST_INSERT_AFTER(listelm, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.le_next = (listelm)->field.le_next) != NULL)\x0009\&\\\n\+ \\x0009\&\x0009\&(listelm)->field.le_next->field.le_prev =\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    &(elm)->field.le_next;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(listelm)->field.le_next = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.le_prev = &(listelm)->field.le_next;\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&LIST_INSERT_BEFORE(listelm, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.le_prev = (listelm)->field.le_prev;\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.le_next = (listelm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&*(listelm)->field.le_prev = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(listelm)->field.le_prev = &(elm)->field.le_next;\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&LIST_INSERT_HEAD(head, elm, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.le_next = (head)->lh_first) != NULL)\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->lh_first->field.le_prev = &(elm)->field.le_next;\\\n\+ \\x0009\&(head)->lh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.le_prev = &(head)->lh_first;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&LIST_REMOVE(elm, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((elm)->field.le_next != NULL)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(elm)->field.le_next->field.le_prev = \x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    (elm)->field.le_prev;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&*(elm)->field.le_prev = (elm)->field.le_next;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&LIST_FOREACH(var, head, field)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = ((head)->lh_first);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = ((var)->field.le_next))\n\+ \\n\+ \/*\n\+ \ * List access methods.\n\+ \ */\n\+ \#define\x0009\&LIST_EMPTY(head)\x0009\&\x0009\&((head)->lh_first == NULL)\n\+ \#define\x0009\&LIST_FIRST(head)\x0009\&\x0009\&((head)->lh_first)\n\+ \#define\x0009\&LIST_NEXT(elm, field)\x0009\&\x0009\&((elm)->field.le_next)\n\+ \\n\+ \/*\n\+ \ * Singly-linked List definitions.\n\+ \ */\n\+ \#define\x0009\&SLIST_HEAD(name, type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct name {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *slh_first;\x0009\&/* first element */\x0009\&\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \#define\x0009\&SLIST_HEAD_INITIALIZER(head)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&{ NULL }\n\+ \\n\+ \#define\x0009\&SLIST_ENTRY(type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *sle_next;\x0009\&/* next element */\x0009\&\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \/*\n\+ \ * Singly-linked List functions.\n\+ \ */\n\+ \#define\x0009\&SLIST_INIT(head) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->slh_first = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SLIST_INSERT_AFTER(slistelm, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.sle_next = (slistelm)->field.sle_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(slistelm)->field.sle_next = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SLIST_INSERT_HEAD(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.sle_next = (head)->slh_first;\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->slh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SLIST_REMOVE_HEAD(head, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->slh_first = (head)->slh_first->field.sle_next;\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SLIST_REMOVE(head, elm, type, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((head)->slh_first == (elm)) {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&SLIST_REMOVE_HEAD((head), field);\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&}\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&struct type *curelm = (head)->slh_first;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&while(curelm->field.sle_next != (elm))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&\x0009\&curelm = curelm->field.sle_next;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&curelm->field.sle_next =\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    curelm->field.sle_next->field.sle_next;\x0009\&\x0009\&\\\n\+ \\x0009\&}\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SLIST_FOREACH(var, head, field)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for((var) = (head)->slh_first; (var); (var) = (var)->field.sle_next)\n\+ \\n\+ \/*\n\+ \ * Singly-linked List access methods.\n\+ \ */\n\+ \#define\x0009\&SLIST_EMPTY(head)\x0009\&((head)->slh_first == NULL)\n\+ \#define\x0009\&SLIST_FIRST(head)\x0009\&((head)->slh_first)\n\+ \#define\x0009\&SLIST_NEXT(elm, field)\x0009\&((elm)->field.sle_next)\n\+ \\n\+ \/*\n\+ \ * Singly-linked Tail queue declarations.\n\+ \ */\n\+ \#define\x0009\&STAILQ_HEAD(name, type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct name {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *stqh_first;\x0009\&/* first element */\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type **stqh_last;\x0009\&/* addr of last next element */\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \#define\x0009\&STAILQ_HEAD_INITIALIZER(head)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&{ NULL, &(head).stqh_first }\n\+ \\n\+ \#define\x0009\&STAILQ_ENTRY(type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *stqe_next;\x0009\&/* next element */\x0009\&\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \/*\n\+ \ * Singly-linked Tail queue functions.\n\+ \ */\n\+ \#define\x0009\&STAILQ_INIT(head) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->stqh_first = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->stqh_last = &(head)->stqh_first;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&STAILQ_INSERT_HEAD(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.stqe_next = (head)->stqh_first) == NULL)\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->stqh_last = &(elm)->field.stqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->stqh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&STAILQ_INSERT_TAIL(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.stqe_next = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&*(head)->stqh_last = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->stqh_last = &(elm)->field.stqe_next;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&STAILQ_INSERT_AFTER(head, listelm, elm, field) do {\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.stqe_next = (listelm)->field.stqe_next) == NULL)\\\n\+ \\x0009\&\x0009\&(head)->stqh_last = &(elm)->field.stqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(listelm)->field.stqe_next = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&STAILQ_REMOVE_HEAD(head, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((head)->stqh_first = (head)->stqh_first->field.stqe_next) == NULL) \\\n\+ \\x0009\&\x0009\&(head)->stqh_last = &(head)->stqh_first;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&STAILQ_REMOVE(head, elm, type, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((head)->stqh_first == (elm)) {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&STAILQ_REMOVE_HEAD((head), field);\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&} else {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&struct type *curelm = (head)->stqh_first;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&while (curelm->field.stqe_next != (elm))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&\x0009\&curelm = curelm->field.stqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&if ((curelm->field.stqe_next =\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&\x0009\&curelm->field.stqe_next->field.stqe_next) == NULL) \\\n\+ \\x0009\&\x0009\&\x0009\&    (head)->stqh_last = &(curelm)->field.stqe_next; \\\n\+ \\x0009\&}\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&STAILQ_FOREACH(var, head, field)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = ((head)->stqh_first);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = ((var)->field.stqe_next))\n\+ \\n\+ \#define\x0009\&STAILQ_CONCAT(head1, head2) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (!STAILQ_EMPTY((head2))) {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&*(head1)->stqh_last = (head2)->stqh_first;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head1)->stqh_last = (head2)->stqh_last;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&STAILQ_INIT((head2));\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&}\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \/*\n\+ \ * Singly-linked Tail queue access methods.\n\+ \ */\n\+ \#define\x0009\&STAILQ_EMPTY(head)\x0009\&((head)->stqh_first == NULL)\n\+ \#define\x0009\&STAILQ_FIRST(head)\x0009\&((head)->stqh_first)\n\+ \#define\x0009\&STAILQ_NEXT(elm, field)\x0009\&((elm)->field.stqe_next)\n\+ \\n\+ \/*\n\+ \ * Simple queue definitions.\n\+ \ */\n\+ \#define\x0009\&SIMPLEQ_HEAD(name, type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct name {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *sqh_first;\x0009\&/* first element */\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type **sqh_last;\x0009\&/* addr of last next element */\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \#define\x0009\&SIMPLEQ_HEAD_INITIALIZER(head)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&{ NULL, &(head).sqh_first }\n\+ \\n\+ \#define\x0009\&SIMPLEQ_ENTRY(type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *sqe_next;\x0009\&/* next element */\x0009\&\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \/*\n\+ \ * Simple queue functions.\n\+ \ */\n\+ \#define\x0009\&SIMPLEQ_INIT(head) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->sqh_first = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->sqh_last = &(head)->sqh_first;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SIMPLEQ_INSERT_HEAD(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.sqe_next = (head)->sqh_first) == NULL)\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->sqh_last = &(elm)->field.sqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->sqh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SIMPLEQ_INSERT_TAIL(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.sqe_next = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&*(head)->sqh_last = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->sqh_last = &(elm)->field.sqe_next;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SIMPLEQ_INSERT_AFTER(head, listelm, elm, field) do {\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.sqe_next = (listelm)->field.sqe_next) == NULL)\\\n\+ \\x0009\&\x0009\&(head)->sqh_last = &(elm)->field.sqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(listelm)->field.sqe_next = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SIMPLEQ_REMOVE_HEAD(head, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((head)->sqh_first = (head)->sqh_first->field.sqe_next) == NULL) \\\n\+ \\x0009\&\x0009\&(head)->sqh_last = &(head)->sqh_first;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SIMPLEQ_REMOVE(head, elm, type, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((head)->sqh_first == (elm)) {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&SIMPLEQ_REMOVE_HEAD((head), field);\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&} else {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&struct type *curelm = (head)->sqh_first;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&while (curelm->field.sqe_next != (elm))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&\x0009\&curelm = curelm->field.sqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&if ((curelm->field.sqe_next =\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&\x0009\&curelm->field.sqe_next->field.sqe_next) == NULL) \\\n\+ \\x0009\&\x0009\&\x0009\&    (head)->sqh_last = &(curelm)->field.sqe_next; \\\n\+ \\x0009\&}\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&SIMPLEQ_FOREACH(var, head, field)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = ((head)->sqh_first);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = ((var)->field.sqe_next))\n\+ \\n\+ \/*\n\+ \ * Simple queue access methods.\n\+ \ */\n\+ \#define\x0009\&SIMPLEQ_EMPTY(head)\x0009\&\x0009\&((head)->sqh_first == NULL)\n\+ \#define\x0009\&SIMPLEQ_FIRST(head)\x0009\&\x0009\&((head)->sqh_first)\n\+ \#define\x0009\&SIMPLEQ_NEXT(elm, field)\x0009\&((elm)->field.sqe_next)\n\+ \\n\+ \/*\n\+ \ * Tail queue definitions.\n\+ \ */\n\+ \#define\x0009\&_TAILQ_HEAD(name, type, qual)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct name {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&qual type *tqh_first;\x0009\&\x0009\&/* first element */\x0009\&\x0009\&\\\n\+ \\x0009\&qual type *qual *tqh_last;\x0009\&/* addr of last next element */\x0009\&\\\n\+ \}\n\+ \#define TAILQ_HEAD(name, type)\x0009\&_TAILQ_HEAD(name, struct type,)\n\+ \\n\+ \#define\x0009\&TAILQ_HEAD_INITIALIZER(head)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&{ NULL, &(head).tqh_first }\n\+ \\n\+ \#define\x0009\&_TAILQ_ENTRY(type, qual)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&qual type *tqe_next;\x0009\&\x0009\&/* next element */\x0009\&\x0009\&\\\n\+ \\x0009\&qual type *qual *tqe_prev;\x0009\&/* address of previous next element */\\\n\+ \}\n\+ \#define TAILQ_ENTRY(type)\x0009\&_TAILQ_ENTRY(struct type,)\n\+ \\n\+ \/*\n\+ \ * Tail queue functions.\n\+ \ */\n\+ \#define\x0009\&TAILQ_INIT(head) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->tqh_first = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->tqh_last = &(head)->tqh_first;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&TAILQ_INSERT_HEAD(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.tqe_next = (head)->tqh_first) != NULL)\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->tqh_first->field.tqe_prev =\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    &(elm)->field.tqe_next;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->tqh_last = &(elm)->field.tqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->tqh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.tqe_prev = &(head)->tqh_first;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&TAILQ_INSERT_TAIL(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.tqe_next = NULL;\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.tqe_prev = (head)->tqh_last;\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&*(head)->tqh_last = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->tqh_last = &(elm)->field.tqe_next;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&TAILQ_INSERT_AFTER(head, listelm, elm, field) do {\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.tqe_next = (listelm)->field.tqe_next) != NULL)\\\n\+ \\x0009\&\x0009\&(elm)->field.tqe_next->field.tqe_prev = \x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    &(elm)->field.tqe_next;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->tqh_last = &(elm)->field.tqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(listelm)->field.tqe_next = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.tqe_prev = &(listelm)->field.tqe_next;\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&TAILQ_INSERT_BEFORE(listelm, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.tqe_prev = (listelm)->field.tqe_prev;\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.tqe_next = (listelm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&*(listelm)->field.tqe_prev = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(listelm)->field.tqe_prev = &(elm)->field.tqe_next;\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&TAILQ_REMOVE(head, elm, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (((elm)->field.tqe_next) != NULL)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(elm)->field.tqe_next->field.tqe_prev = \x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    (elm)->field.tqe_prev;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->tqh_last = (elm)->field.tqe_prev;\x0009\&\x0009\&\\\n\+ \\x0009\&*(elm)->field.tqe_prev = (elm)->field.tqe_next;\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&TAILQ_FOREACH(var, head, field)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = ((head)->tqh_first);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = ((var)->field.tqe_next))\n\+ \\n\+ \#define\x0009\&TAILQ_FOREACH_REVERSE(var, head, headname, field)\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = (*(((struct headname *)((head)->tqh_last))->tqh_last));\x0009\&\\\n\+ \\x0009\&\x0009\&(var);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = (*(((struct headname *)((var)->field.tqe_prev))->tqh_last)))\n\+ \\n\+ \#define\x0009\&TAILQ_CONCAT(head1, head2, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if (!TAILQ_EMPTY(head2)) {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&*(head1)->tqh_last = (head2)->tqh_first;\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head2)->tqh_first->field.tqe_prev = (head1)->tqh_last;\x0009\&\\\n\+ \\x0009\&\x0009\&(head1)->tqh_last = (head2)->tqh_last;\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&TAILQ_INIT((head2));\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&}\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \/*\n\+ \ * Tail queue access methods.\n\+ \ */\n\+ \#define\x0009\&TAILQ_EMPTY(head)\x0009\&\x0009\&((head)->tqh_first == NULL)\n\+ \#define\x0009\&TAILQ_FIRST(head)\x0009\&\x0009\&((head)->tqh_first)\n\+ \#define\x0009\&TAILQ_NEXT(elm, field)\x0009\&\x0009\&((elm)->field.tqe_next)\n\+ \\n\+ \#define\x0009\&TAILQ_LAST(head, headname) \\\n\+ \\x0009\&(*(((struct headname *)((head)->tqh_last))->tqh_last))\n\+ \#define\x0009\&TAILQ_PREV(elm, headname, field) \\\n\+ \\x0009\&(*(((struct headname *)((elm)->field.tqe_prev))->tqh_last))\n\+ \\n\+ \/*\n\+ \ * Circular queue definitions.\n\+ \ */\n\+ \#define\x0009\&CIRCLEQ_HEAD(name, type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct name {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *cqh_first;\x0009\&\x0009\&/* first element */\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *cqh_last;\x0009\&\x0009\&/* last element */\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \#define\x0009\&CIRCLEQ_HEAD_INITIALIZER(head)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&{ (void *)&head, (void *)&head }\n\+ \\n\+ \#define\x0009\&CIRCLEQ_ENTRY(type)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \struct {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *cqe_next;\x0009\&\x0009\&/* next element */\x0009\&\x0009\&\\\n\+ \\x0009\&struct type *cqe_prev;\x0009\&\x0009\&/* previous element */\x0009\&\x0009\&\\\n\+ \}\n\+ \\n\+ \/*\n\+ \ * Circular queue functions.\n\+ \ */\n\+ \#define\x0009\&CIRCLEQ_INIT(head) do {\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->cqh_first = (void *)(head);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->cqh_last = (void *)(head);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&CIRCLEQ_INSERT_AFTER(head, listelm, elm, field) do {\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_next = (listelm)->field.cqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_prev = (listelm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((listelm)->field.cqe_next == (void *)(head))\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_last = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(listelm)->field.cqe_next->field.cqe_prev = (elm);\x0009\&\\\n\+ \\x0009\&(listelm)->field.cqe_next = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&CIRCLEQ_INSERT_BEFORE(head, listelm, elm, field) do {\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_next = (listelm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_prev = (listelm)->field.cqe_prev;\x0009\&\x0009\&\\\n\+ \\x0009\&if ((listelm)->field.cqe_prev == (void *)(head))\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(listelm)->field.cqe_prev->field.cqe_next = (elm);\x0009\&\\\n\+ \\x0009\&(listelm)->field.cqe_prev = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&CIRCLEQ_INSERT_HEAD(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_next = (head)->cqh_first;\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_prev = (void *)(head);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((head)->cqh_last == (void *)(head))\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_last = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_first->field.cqe_prev = (elm);\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->cqh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&CIRCLEQ_INSERT_TAIL(head, elm, field) do {\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_next = (void *)(head);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(elm)->field.cqe_prev = (head)->cqh_last;\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((head)->cqh_first == (void *)(head))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_first = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_last->field.cqe_next = (elm);\x0009\&\x0009\&\\\n\+ \\x0009\&(head)->cqh_last = (elm);\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&CIRCLEQ_REMOVE(head, elm, field) do {\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((elm)->field.cqe_next == (void *)(head))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_last = (elm)->field.cqe_prev;\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(elm)->field.cqe_next->field.cqe_prev =\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    (elm)->field.cqe_prev;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&if ((elm)->field.cqe_prev == (void *)(head))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(head)->cqh_first = (elm)->field.cqe_next;\x0009\&\x0009\&\\\n\+ \\x0009\&else\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(elm)->field.cqe_prev->field.cqe_next =\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&    (elm)->field.cqe_next;\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \} while (/*CONSTCOND*/0)\n\+ \\n\+ \#define\x0009\&CIRCLEQ_FOREACH(var, head, field)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = ((head)->cqh_first);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) != (const void *)(head);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = ((var)->field.cqe_next))\n\+ \\n\+ \#define\x0009\&CIRCLEQ_FOREACH_REVERSE(var, head, field)\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&for ((var) = ((head)->cqh_last);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) != (const void *)(head);\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&\x0009\&(var) = ((var)->field.cqe_prev))\n\+ \\n\+ \/*\n\+ \ * Circular queue access methods.\n\+ \ */\n\+ \#define\x0009\&CIRCLEQ_EMPTY(head)\x0009\&\x0009\&((head)->cqh_first == (void *)(head))\n\+ \#define\x0009\&CIRCLEQ_FIRST(head)\x0009\&\x0009\&((head)->cqh_first)\n\+ \#define\x0009\&CIRCLEQ_LAST(head)\x0009\&\x0009\&((head)->cqh_last)\n\+ \#define\x0009\&CIRCLEQ_NEXT(elm, field)\x0009\&((elm)->field.cqe_next)\n\+ \#define\x0009\&CIRCLEQ_PREV(elm, field)\x0009\&((elm)->field.cqe_prev)\n\+ \\n\+ \#define CIRCLEQ_LOOP_NEXT(head, elm, field)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(((elm)->field.cqe_next == (void *)(head))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&    ? ((head)->cqh_first)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&    : (elm->field.cqe_next))\n\+ \#define CIRCLEQ_LOOP_PREV(head, elm, field)\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&(((elm)->field.cqe_prev == (void *)(head))\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&    ? ((head)->cqh_last)\x0009\&\x0009\&\x0009\&\x0009\&\x0009\&\\\n\+ \\x0009\&    : (elm->field.cqe_prev))\n\+ \\n\+ \#endif\x0009\&/* sys/queue.h */\n\+ \"#++-- | Generated from rts\/HsFFI.h+{-# NOINLINE hsffi_h #-}+hsffi_h :: ByteString+hsffi_h = unsafePerformIO $ unsafePackAddress "\+ \/* HsFFI.h for jhc */\n\+ \\n\+ \#ifndef _JHC_HSFFI_H\n\+ \#define _JHC_HSFFI_H\n\+ \\n\+ \#include <stdint.h>\n\+ \#include <stdbool.h>\n\+ \#include <stddef.h>\n\+ \\n\+ \typedef int32_t HsInt;\n\+ \typedef int8_t  HsInt8;\n\+ \typedef int16_t HsInt16;\n\+ \typedef int32_t HsInt32;\n\+ \typedef int64_t HsInt64;\n\+ \\n\+ \typedef uint32_t HsWord;\n\+ \typedef uint8_t  HsWord8;\n\+ \typedef uint16_t HsWord16;\n\+ \typedef uint32_t HsWord32;\n\+ \typedef uint64_t HsWord64;\n\+ \\n\+ \typedef wchar_t HsChar;\n\+ \typedef bool HsBool;\n\+ \\n\+ \typedef double HsDouble;\n\+ \typedef float HsFloat;\n\+ \\n\+ \typedef void *HsPtr;\n\+ \typedef void (*HsFunPtr)(void);\n\+ \typedef void *HsStablePtr;\n\+ \\n\+ \#define HS_BOOL_FALSE 0\n\+ \#define HS_BOOL_TRUE 1\n\+ \\n\+ \void hs_init (int *argc, char **argv[]);\n\+ \void hs_exit (void);\n\+ \void hs_set_argv(int argc, char *argv[]);\n\+ \void hs_perform_gc(void);\n\+ \void hs_free_stable_ptr(HsStablePtr sp);\n\+ \void hs_free_fun_ptr(HsFunPtr fp);\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/sys\/wsize.h+{-# NOINLINE wsize_h #-}+wsize_h :: ByteString+wsize_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef WSIZE_H\n\+ \#define WSIZE_H\n\+ \\n\+ \/*\n\+ \ * wsize.h\n\+ \ * define appropriate __WORDSIZE and __BYTE_ORDER macros\n\+ \ *\n\+ \ * always use operating systems headers rather than checking for architectures\n\+ \ * when possible. if adding new cases. Checking the CPU type should be a last\n\+ \ * resort.\n\+ \ *\n\+ \ */\n\+ \\n\+ \#include <limits.h>\n\+ \\n\+ \#ifdef __linux__\n\+ \#include<endian.h>\n\+ \#endif\n\+ \\n\+ \#ifndef __LITTLE_ENDIAN\n\+ \#define\x0009\&__LITTLE_ENDIAN\x0009\&1234\n\+ \#endif\n\+ \#ifndef __BIG_ENDIAN\n\+ \#define\x0009\&__BIG_ENDIAN\x0009\&4321\n\+ \#endif\n\+ \#ifndef __PDP_ENDIAN\n\+ \#define\x0009\&__PDP_ENDIAN\x0009\&3412\n\+ \#endif\n\+ \\n\+ \#ifndef __BYTE_ORDER\n\+ \#ifdef _BIG_ENDIAN\n\+ \#define __BYTE_ORDER __BIG_ENDIAN\n\+ \#elif defined(__BIG_ENDIAN__)\n\+ \#define __BYTE_ORDER __BIG_ENDIAN\n\+ \#elif defined(_LITTLE_ENDIAN)\n\+ \#define __BYTE_ORDER __LITTLE_ENDIAN\n\+ \#elif defined(__LITTLE_ENDIAN__)\n\+ \#define __BYTE_ORDER __LITTLE_ENDIAN\n\+ \#elif defined(__i386__)\n\+ \#define __BYTE_ORDER __LITTLE_ENDIAN\n\+ \#else\n\+ \#error Could not determine Byte Order\n\+ \#endif\n\+ \#endif\n\+ \\n\+ \#ifndef __WORDSIZE\n\+ \#ifdef __SIZEOF_POINTER__\n\+ \#define __WORDSIZE (CHAR_BIT*__SIZEOF_POINTER__)\n\+ \#elif defined(__i386__)\n\+ \#define __WORDSIZE 32\n\+ \#elif defined(__x86_64__)\n\+ \#define __WORDSIZE 64\n\+ \#else\n\+ \#error Could not determine bitsize\n\+ \#endif\n\+ \#endif\n\+ \\n\+ \#ifdef TEST_WSIZE\n\+ \#include <stdio.h>\n\+ \int\n\+ \main(int argc, char *argv[])\n\+ \{\n\+ \    printf(\"__WORDSIZE:   %i\\n\", __WORDSIZE);\n\+ \    printf(\"__BYTE_ORDER: %i\\n\", __BYTE_ORDER);\n\+ \    return 0;\n\+ \}\n\+ \#endif\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/sys\/bitarray.h+{-# NOINLINE bitarray_h #-}+bitarray_h :: ByteString+bitarray_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef BITARRAY_H\n\+ \#define BITARRAY_H\n\+ \\n\+ \#include <limits.h>\n\+ \#include <stdbool.h>\n\+ \\n\+ \typedef unsigned long bitarray_t;\n\+ \\n\+ \#define BITS_PER_UNIT (bitarray_t)(CHAR_BIT*sizeof(bitarray_t))\n\+ \#define BITARRAY_SIZE(bits) (((bits) + (BITS_PER_UNIT - 1)) / BITS_PER_UNIT)\n\+ \#define BITARRAY_SIZE_IN_BYTES(bits) (sizeof(bitarray_t)*BITARRAY_SIZE(bits))\n\+ \\n\+ \#define WHICH_BIT(bit)  \\\n\+ \    (1UL << ((((bitarray_t)(bit)) % BITS_PER_UNIT)))\n\+ \\n\+ \#define OFFSET_IN_ARRAY(array,bit) \\\n\+ \    (((bitarray_t *)(array))[((bitarray_t)(bit)) / BITS_PER_UNIT])\n\+ \\n\+ \#define BIT_IS_SET(array,bit)  \\\n\+ \    (OFFSET_IN_ARRAY(array,bit) & WHICH_BIT(bit))\n\+ \\n\+ \#define BIT_IS_UNSET(array,bit) \\\n\+ \    (!(BIT_IS_SET(array,bit)))\n\+ \\n\+ \#define BIT_SET(array,bit) \\\n\+ \    (OFFSET_IN_ARRAY(array,bit) |= WHICH_BIT(bit))\n\+ \\n\+ \#define BIT_UNSET(array,bit) \\\n\+ \    (OFFSET_IN_ARRAY(array,bit) &= ~WHICH_BIT(bit))\n\+ \\n\+ \#define BIT_TOGGLE(array,bit) \\\n\+ \    (OFFSET_IN_ARRAY(array,bit) ^= WHICH_BIT(bit))\n\+ \\n\+ \#define BIT_COPY(dest,src,bit)  \\\n\+ \    do { BIT_IS_SET((src),(bit)) ? BIT_SET((dest),(bit)) : BIT_UNSET((dest),(bit)) } while(0)\n\+ \\n\+ \#define BIT_VALUE(array,bit) \\\n\+ \    (BIT_IS_SET((array),(bit)) ? true : false)\n\+ \\n\+ \#define BIT_SET_VALUE(array,bit,value) \\\n\+ \    do { (value) ? BIT_SET((array),(bit)) : BIT_UNSET((array),(bit)) } while(0)\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from ChangeLog+{-# NOINLINE changelog #-}+changelog :: ByteString+changelog = unsafePerformIO $ unsafePackAddress "\+ \commit f1bf6e4a473a42ac193097a84adebd6506b61209\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Apr 2 01:23:29 2013 +0900\n\+ \\n\+ \    Avoid 500 error while running LWP::Simple getstore.\n\+ \\n\+ \commit d256d40e5a89d37d350cdbcb8e2f9c0d00289ff4\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Apr 2 00:06:33 2013 +0900\n\+ \\n\+ \    Fix a bit miss.\n\+ \\n\+ \commit 959c0739d7804b064870bec1cdcce5b3ad70d379\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 23:08:12 2013 +0900\n\+ \\n\+ \    Do not use \"ajhc\" name to avoid conflicting between jhc and Ajhc.\n\+ \\n\+ \commit ab4989d6e672e5488cf1ad36974e6a1cf16ddf6d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 22:17:42 2013 +0900\n\+ \\n\+ \    Update README.\n\+ \\n\+ \commit 4c66ba7dc37d103e8704fca2cb6923ae3832dc23\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 21:20:23 2013 +0900\n\+ \\n\+ \    Do not forge to add utils/build_extlibs.prl to cabal sdist.\n\+ \\n\+ \commit 8a873e456a39f7b92613536a89b5205cf784f6b0\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 21:00:46 2013 +0900\n\+ \\n\+ \    Install JHC_EXT_LIBS with cabal install.\n\+ \\n\+ \commit 5c043d61c5201af057089973a3c6bc0db026567d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 19:20:38 2013 +0900\n\+ \\n\+ \    Ready to cabal install me on Windows + MinGW32 env without JHC_EXT_LIBS.\n\+ \\n\+ \commit c7e2bf3f129f44a20e4350f1b7c7ad84720c9a4e\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 17:24:46 2013 +0900\n\+ \\n\+ \    Add prefix \"sh -c \" for system function on mingw32.\n\+ \\n\+ \commit 7f81fb4a41f6a6f272f4a39ada258e8776a65bd4\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 15:45:19 2013 +0900\n\+ \\n\+ \    Windows install Haskell Platform to directory  has path string include space.\n\+ \\n\+ \commit 012f092f7bd74a12f10a495da3c177818932653d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 15:04:43 2013 +0900\n\+ \\n\+ \    Fix NAIVEGC bug. Should update pg after running gc_perform_gc.\n\+ \\n\+ \commit 4b122fd809092c31211fdd8e18283622c3651513\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 03:52:56 2013 +0900\n\+ \\n\+ \    Find data directory with getDataFileName function.\n\+ \\n\+ \commit 6b014de73f6381701bc03926f1f75683589f1694\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 02:36:08 2013 +0900\n\+ \\n\+ \    Should write like below style for Windows + msys env.\n\+ \    \n\+ \      install FILES \"DESTDIR\"\n\+ \\n\+ \commit 232129a84378c306970b2c4ec4d5b0a3dc74958d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Apr 1 01:45:02 2013 +0900\n\+ \\n\+ \    List up the files in \"lib\" directory to include them on cabal sdist file.\n\+ \\n\+ \commit 166f0b90ea3f319a1841961e4212213a1750374b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 31 23:42:41 2013 +0900\n\+ \\n\+ \    Build JHC_LIBS with cabal. (not yet JHC_EXT_LIBS)\n\+ \\n\+ \commit a7e0de37f89d1f8f4cdae4a873c11412c342ea8a\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 31 21:25:17 2013 +0900\n\+ \\n\+ \    Update TODO.\n\+ \\n\+ \commit e1a0fbd87e56a8f45c127492adf9433c85df5618\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 31 21:24:37 2013 +0900\n\+ \\n\+ \    Build ajhc with cabal without hl files.\n\+ \\n\+ \commit e4a396ef63dd26518073b789480b1c3f5268e444\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 31 20:13:23 2013 +0900\n\+ \\n\+ \    No more depend on haskell98 package.\n\+ \\n\+ \commit 2e58f4f259507eb7eb67a894db81c23e056465d8\n\+ \Merge: 8de6364 58a1bf6\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 30 01:23:53 2013 +0900\n\+ \\n\+ \    Merge branch 'arafura' of github.com:ajhc/ajhc into arafura\n\+ \\n\+ \commit 8de63645df6cc30f9874b12b18da032acc0a28d0\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 30 01:23:16 2013 +0900\n\+ \\n\+ \    Add BUGGY cabal file.\n\+ \\n\+ \commit 58a1bf61639157e3ac3e9c55cc2f4ba33d592eb7\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date:   Fri Mar 29 21:53:45 2013 +0900\n\+ \\n\+ \    a bit change.\n\+ \\n\+ \commit 7675b1599fe41531b4c89a2ada947fa8f601161d\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date:   Fri Mar 29 21:44:42 2013 +0900\n\+ \\n\+ \    Build on Windows (in the make)\n\+ \\n\+ \commit 38275f78b7ff585616e2a7846cedccbf2f0dd0b8\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 29 20:13:56 2013 +0900\n\+ \\n\+ \    Add msys path to library search path.\n\+ \\n\+ \commit cbfe1a5cd1bc660adc126056bfe17dbce529f8bd\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 29 19:31:22 2013 +0900\n\+ \\n\+ \    Update README.md.\n\+ \\n\+ \commit e99327bbe221b35c63e4c2639462330d1c978b6c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 29 17:55:26 2013 +0900\n\+ \\n\+ \    Explain how to build on Windows.\n\+ \\n\+ \commit 376103c6d2dfe3d77920b340f8295d174c274b79\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 29 17:28:28 2013 +0900\n\+ \\n\+ \    Ready to build me on Windows.\n\+ \\n\+ \commit 6024a1823e6782f3d03c8263bcfd50bbba83ba33\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 29 08:57:29 2013 +0900\n\+ \\n\+ \    Stacktrace with running \"ajhcp Foo.hs +RTS -p -xc\".\n\+ \\n\+ \commit 20edf78270d89fc8602e37863980bec0228bb647\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 29 07:44:28 2013 +0900\n\+ \\n\+ \    Use \"DrIFT-cabalized\" command name, if use DrIFT-cabalized Haskell package.\n\+ \\n\+ \commit e3a1a65e326e1a3b31fc5eb03c89a611a56d1970\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Thu Mar 28 22:20:22 2013 +0900\n\+ \\n\+ \    Find and use DrIFT-cabalized.\n\+ \\n\+ \commit 293eb5a89fe27f25c623996e7670cd8984768319\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Wed Mar 27 13:16:56 2013 +0900\n\+ \\n\+ \    Use System.IO.Temp instead of mkdtemp.\n\+ \\n\+ \commit 8ab1f6aebdfd466be988f70611c60450664ca47b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Wed Mar 27 12:16:50 2013 +0900\n\+ \\n\+ \    Switch compile for Windows or UNIX with USE_WIN32 flag.\n\+ \\n\+ \commit 76671e2eb7b91b482a413d93d657bbd374c66f1d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Wed Mar 27 06:00:41 2013 +0900\n\+ \\n\+ \    Fix setting EXEEXT in Makefile.\n\+ \\n\+ \commit e49aebef308f40a1e8b1c9b6594c81708b4ce08b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Wed Mar 27 03:18:58 2013 +0900\n\+ \\n\+ \    Use haskeline haskell package instead of readline or editline. (cont.)\n\+ \\n\+ \commit 751f34f46df2afad207748b3d4af66155a9b1c64\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 26 01:20:05 2013 +0900\n\+ \\n\+ \    Dump megablocks on gdb.\n\+ \\n\+ \commit c8d53949450b38555c38ce93ebd6d8003d334256\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 26 00:25:57 2013 +0900\n\+ \\n\+ \    Dump s_cache on gdb.\n\+ \\n\+ \commit 9ceab0702c715ca3012da68c350f7e7357722c6d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 23 03:34:53 2013 +0900\n\+ \\n\+ \    Rich gdb command print_jgcheap. (cont.)\n\+ \\n\+ \commit a572ddeb55dc28124c4c2fba09330e8b97a6dce5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 22 22:49:15 2013 +0900\n\+ \\n\+ \    Do not use gdb.parse_and_eval in loop. It's very slow.\n\+ \\n\+ \commit cbdcfce5d3bc0d74d67d097f0e0ccf4a77ecb00c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 22 22:20:44 2013 +0900\n\+ \\n\+ \    Pytyon script to dump Haskell heap on gdb.\n\+ \\n\+ \commit 25cb7c8e298eb75e26dcdf56d4bd532d6bbd641b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 22 02:21:18 2013 +0900\n\+ \\n\+ \    Update Future plan.\n\+ \\n\+ \commit b7e82942abed041e519c4709a591096367bdf158\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Wed Mar 20 12:21:38 2013 +0900\n\+ \\n\+ \    ignore .ditz-config file on git command\n\+ \\n\+ \commit 46ba77fa0f2ed1fa16acdedae737deab365c9c25\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 19 21:52:39 2013 +0900\n\+ \\n\+ \    Use \"JHC_XXX\" name in Makefile to share source code with jhc.\n\+ \\n\+ \commit 830a6f81207bac4394f8981e3f432821358d862b\n\+ \Merge: 870430b 2adf411\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 19 20:50:19 2013 +0900\n\+ \\n\+ \    Merge branch 'master' into arafura\n\+ \    \n\+ \    Conflicts:\n\+ \    \x0009\&library_deps.make\n\+ \\n\+ \commit 870430b35629ec2ca8d498b5f198bd2d8610edfe\n\+ \Merge: f1fb1c6 ddafc44\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 17 16:30:24 2013 +0900\n\+ \\n\+ \    Merge branch 'master' into arafura\n\+ \    \n\+ \    Conflicts:\n\+ \    \x0009\&Makefile.am\n\+ \    \x0009\&po/ja.po\n\+ \    \x0009\&src/Grin/Grin.hs\n\+ \\n\+ \commit f1fb1c6304bc85b71d3fb0558fad7804d5565d60\n\+ \Merge: fa1a95b de85f4e\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 17 16:19:20 2013 +0900\n\+ \\n\+ \    Merge branch 'master' into arafura\n\+ \    \n\+ \    Conflicts:\n\+ \    \x0009\&rts/rts/gc_jgc.c\n\+ \\n\+ \commit 2adf411caac22cf15b1d63d2de80ec9e3b12e843\n\+ \Author: kiwamu <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 17 16:06:29 2013 +0900\n\+ \\n\+ \    Upgrade some JHC_EXT_LIBS.\n\+ \    \n\+ \    Ignore-this: d51be66b69fbe0240775f1464a4d46e7\n\+ \    \n\+ \    darcs-hash:20130317070629-99646-8d122ceea5273835030a18ac965842896f8f42e1.gz\n\+ \\n\+ \commit ac8ddb00ddc5aa3580ce3e68cb2773f1536cb638\n\+ \Author: kiwamu <kiwamu@debian.or.jp>\n\+ \Date:   Sun Mar 17 02:21:07 2013 +0900\n\+ \\n\+ \    Explain RTS cflags for tiny cpu.\n\+ \    \n\+ \    Ignore-this: b09e6da5e1704b9da4a51ae6a23f57ee\n\+ \    \n\+ \    darcs-hash:20130316172107-99646-d9545e56b6d11bf6511bf35a793f2246cae9b697.gz\n\+ \\n\+ \commit fa1a95b48fec10d2ee2adc30f5c447cdb36564e5\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date:   Sat Mar 16 23:10:41 2013 +0900\n\+ \\n\+ \    About darcs send command.\n\+ \\n\+ \commit ddafc4422bea272707775cd680058232b9b40e07\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 22:14:24 2013 +0900\n\+ \\n\+ \    add Japanese translation\n\+ \    \n\+ \    Ignore-this: 771722900017d423f40b25f917392680\n\+ \    \n\+ \    darcs-hash:20130316131424-1a7c6-1f6707f0212f861d0af8aad5a573efa1a4107879.gz\n\+ \\n\+ \commit c753139eff5275fe8a48b0ce7fccd0a387409406\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 22:07:34 2013 +0900\n\+ \\n\+ \    improve error message\n\+ \    \n\+ \    Ignore-this: e90f98c675cc6df2770c8bba3a7c313\n\+ \    \n\+ \    darcs-hash:20130316130734-1a7c6-5e34d40efe9979f39d53361dbd0c194b1d050af3.gz\n\+ \\n\+ \commit 340727f1a7eb881ba8fec88d77218ad622beb20a\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 22:07:04 2013 +0900\n\+ \\n\+ \    add printing of attributed, conjunctive, and disjunctive types.\n\+ \    \n\+ \    Ignore-this: 71f5c1b073bf7a11bc6187345e03e6d0\n\+ \    \n\+ \    darcs-hash:20130316130704-1a7c6-4a14b9c3d272dc9d345f3b837fd2adb13997e8cb.gz\n\+ \\n\+ \commit 712c3748d829da2c6c9c8b5cd3044066dab68f2d\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 22:04:01 2013 +0900\n\+ \\n\+ \    convert complex types to hardware implemented complex numbers when available\n\+ \    \n\+ \    Ignore-this: ec581ab1eaf5f8e1c920e5741fba50ee\n\+ \    \n\+ \    darcs-hash:20130316130401-1a7c6-162e1c4a44528c0b6c3ec8692027ed79a11468ea.gz\n\+ \\n\+ \commit db29b9d6356de33dae1678f3f4d1f22eab8502ab\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 21:56:30 2013 +0900\n\+ \\n\+ \    Add TyComplex and TyVector to basic types\n\+ \    \n\+ \    Ignore-this: f8a61d1dc3dd99cf7a481a50c192125f\n\+ \    \n\+ \    darcs-hash:20130316125630-1a7c6-82f16b518bcc6bd4d4f692ca8575cd0a65e9c361.gz\n\+ \\n\+ \commit c3db54ed132774c12ba8b8909f458b5681277ad9\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 21:51:21 2013 +0900\n\+ \\n\+ \    from Kiwamu Okabe: fix ghc warnings.\n\+ \    \n\+ \    Ignore-this: 245f7d05dfa93475d82dac08ade9c007\n\+ \    \n\+ \    darcs-hash:20130316125121-1a7c6-489b97df0250c3724bcc458a0210cd23cc5aae47.gz\n\+ \\n\+ \commit 4d8f741cd23aecd87b032ea2b41eaa6fa4e75558\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 21:48:22 2013 +0900\n\+ \\n\+ \    from Kiwamu Okabe: RTS fix for embedded ARM CPUs\n\+ \    \n\+ \    Ignore-this: 40ed352498ff8e20d43410ea772f96c0\n\+ \    \n\+ \    darcs-hash:20130316124822-1a7c6-51653050afc3b9359b57d2b290e480804995a9c4.gz\n\+ \\n\+ \commit d85bd01d86dcfb6067545175f01e6ff2efae7299\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Sat Mar 16 21:46:30 2013 +0900\n\+ \\n\+ \    from Kiwamu Okabe: ghc 7.6 compatibility\n\+ \    \n\+ \    Ignore-this: 953ccf73fee4a1d604eec7b0bfd360d8\n\+ \    \n\+ \    darcs-hash:20130316124630-1a7c6-0fe41016dc7bdf9b1aa6e2d44beab198a3a7ea7d.gz\n\+ \\n\+ \commit 6adebb83357aa04650f0e734182e2ab18581b998\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 16 21:24:46 2013 +0900\n\+ \\n\+ \    Explain demo on tiny CPU.\n\+ \\n\+ \commit 22c38dc56117680319a2c8e3c9fae6b425d353ed\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 16 17:56:43 2013 +0900\n\+ \\n\+ \    Add Ajhc 0.8.0.2 Release Note.\n\+ \\n\+ \commit 904b30ed92df33403c6bae58c7837aca627d1775\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 16 11:43:34 2013 +0900\n\+ \\n\+ \    Do not run CI on master branch.\n\+ \\n\+ \commit 76d810b331b63a7b9accdc7217f9af4a7727eafb\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date:   Sat Mar 16 11:17:42 2013 +0900\n\+ \\n\+ \    Add future plan.\n\+ \\n\+ \commit fad2d6340e429bb0a3d0ae86f50615911a6bb1de\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 21:10:22 2013 +0900\n\+ \\n\+ \    Use git instead of darcs.\n\+ \\n\+ \commit e03a1ee09758f8a0e565e30abd5c88a60f72ee5c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 21:09:49 2013 +0900\n\+ \\n\+ \    Update ja.po.\n\+ \\n\+ \commit 600cb0c4d6ecbbe2ce2e6eea2ddf11a91333635c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 14:32:15 2013 +0900\n\+ \\n\+ \    s/jhc/Ajhc/g on manual_ja.html.\n\+ \\n\+ \commit 971ac8c04a0546b64a5708ddda6be362cb7f76ef\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 13:57:55 2013 +0900\n\+ \\n\+ \    s/jhc/Ajhc/g on manual.html.\n\+ \\n\+ \commit 57948b53329b6ee108ca14571bf1c6e15d541894\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 13:27:03 2013 +0900\n\+ \\n\+ \    A bit change.\n\+ \\n\+ \commit dc57a14f8b5c86e92b034a2706250e66b07d6ce5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 13:09:18 2013 +0900\n\+ \\n\+ \    Explain new cflags for jgc.\n\+ \\n\+ \commit 80aa12fb9b57622bba2f0e911d7ebc0c04ddb662\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Fri Mar 15 01:00:47 2013 +0900\n\+ \\n\+ \    Bump up version 0.8.0.1. New RTS for tiny memory.\n\+ \\n\+ \commit 3167551530b0576cf1f42f928865868ce9aa0b50\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Thu Mar 14 05:09:01 2013 +0900\n\+ \\n\+ \    Copy RTS from demo-cortex-m3.\n\+ \\n\+ \commit eb7206805ca012bca6d7bfeceed668b9c3f6a3d5\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date:   Sun Mar 10 02:59:43 2013 +0900\n\+ \\n\+ \    Explain branch policy.\n\+ \\n\+ \commit 202d113021baf66f5f7534c0eb1776e730e53a48\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Thu Mar 7 19:50:06 2013 +0900\n\+ \\n\+ \    Drop volatile poke patch.\n\+ \    \n\+ \    Read the thread.\n\+ \    http://www.haskell.org/pipermail/jhc/2013-March/001008.html\n\+ \\n\+ \commit de85f4eb5d8688143c83352631c161792e8cc883\n\+ \Author: John Meacham <john@repetae.net>\n\+ \Date:   Wed Mar 6 22:02:31 2013 +0900\n\+ \\n\+ \    Kiwamu Okabe's fix for jhc_aligned_malloc\n\+ \    \n\+ \    Ignore-this: 4413ee55fe27c401d2fb08a752d8811d\n\+ \    \n\+ \    darcs-hash:20130306130231-1a7c6-6f4a8a5ba9870d07ef7548da3f2451a37d1d78f2.gz\n\+ \\n\+ \commit a187199849a4a4cef21bf24c87548374673d81e5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 5 22:47:11 2013 +0900\n\+ \\n\+ \    Add typesig.\n\+ \\n\+ \commit 8b41239136cc607eed0d7974b0d6eb643b95faf8\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 5 19:50:15 2013 +0900\n\+ \\n\+ \    Fix \"Not in scope: `catch'\" error on ghc 7.6.2.\n\+ \\n\+ \commit 647878e884c106439c12c3d271407002dd4196ec\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 5 02:12:31 2013 +0900\n\+ \\n\+ \    Use DoRec instead of RecursiveDo.\n\+ \\n\+ \commit 86f4306ce526f2081724f446e0a253fc3eb3d33b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Tue Mar 5 01:25:45 2013 +0900\n\+ \\n\+ \    Fix many ghc warning. (cont.)\n\+ \\n\+ \commit cbb7aa047150bb98b76abec2f68a3f397853413f\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 22:48:10 2013 +0900\n\+ \\n\+ \    Fix many ghc warning. (cont.)\n\+ \\n\+ \commit 4acae1778d0960e0bcf5038edc2a7158a0582744\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 21:57:20 2013 +0900\n\+ \\n\+ \    Remove unused UNPACK pragma.\n\+ \\n\+ \commit 7409b637f4871d4bda765068c389a8d77c6a2d26\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 21:36:12 2013 +0900\n\+ \\n\+ \    Extract functions derived by DrIFT for fixing \"Defined but not used\" warning.\n\+ \\n\+ \commit 61a96383ad866f599d3950dc1fb7b84a6d7000ca\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 20:16:13 2013 +0900\n\+ \\n\+ \    Fix pattern match(es) are non-exhaustive.\n\+ \\n\+ \commit 151af38ece7ccba7e7f5970948c7fbca3c3bea2d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 18:06:41 2013 +0900\n\+ \\n\+ \    Add iocatch function to use old Prelude.catch.\n\+ \\n\+ \commit 90a685b03ea75fa4e2c7a13f00b5c1d22d8232b2\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 17:16:09 2013 +0900\n\+ \\n\+ \    Fix many ghc warning. (cont.)\n\+ \\n\+ \commit db79e4312182cc8fc5d3a1d0afa48a343faf3729\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 17:14:56 2013 +0900\n\+ \\n\+ \    Set version 0.8.0.0. Ajhc use version number as 0.8.0.x.\n\+ \\n\+ \commit 502b91a34e7b4c8841f563c0eb458ccab858d3e5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 15:41:23 2013 +0900\n\+ \\n\+ \    Fix many ghc warning. / Add cleanup files.\n\+ \\n\+ \commit f64cb5a883c096c2ffd7ce85e22d3c6ec1494892\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Mon Mar 4 13:06:24 2013 +0900\n\+ \\n\+ \    Fix some warning on compile ajhc.\n\+ \\n\+ \commit b3a50378e3d7c5e9f8d52bece2c5250b07f97595\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 18:26:24 2013 +0900\n\+ \\n\+ \    Build manual_ja.html with po4a.\n\+ \\n\+ \commit 531599b10155db4aeb953da3499437320f68efb0\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 17:46:02 2013 +0900\n\+ \\n\+ \    Poke function should use volatile prefix to write memory.\n\+ \\n\+ \commit 7d28d966944f8e29e8b870cb93d82af76a539690\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 17:44:23 2013 +0900\n\+ \\n\+ \    rename aligned_alloc to use it with C11 libc\n\+ \\n\+ \commit 48f25d2099c7e355768ef410e5464f7561a9be36\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 17:23:05 2013 +0900\n\+ \\n\+ \    Remove pbuilder setting, because travis-ci can't use chroot.\n\+ \    \"W: Failure trying to run: chroot /var/cache/pbuilder/build/15916/. mount -t proc proc /proc\"\n\+ \\n\+ \commit 186e80ebf33094e033dc2e537e54c3713a042e56\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 16:55:11 2013 +0900\n\+ \\n\+ \    Fix option miss.\n\+ \\n\+ \commit fbb3fd2aa54dd51288adf8f233d76142b1bac402\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 16:37:30 2013 +0900\n\+ \\n\+ \    Test pbuilder on travis-ci with pbuilderrc file.\n\+ \\n\+ \commit b99be49d897b23663762ebdbe027489b42312581\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 16:09:30 2013 +0900\n\+ \\n\+ \    Test pbuilder on travis-ci.\n\+ \\n\+ \commit cf28f1e69aee1732c335ee79524a9832eeb92776\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 14:10:13 2013 +0900\n\+ \\n\+ \    s/jhc/ajhc/g\n\+ \\n\+ \commit d1002d3d8e296dcdc488a41e604eb6c2898a4731\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 11:44:53 2013 +0900\n\+ \\n\+ \    Add README.md file for github web page and travis-ci build status.\n\+ \\n\+ \commit ac5f7963e6ae1c27769afa2d00200c1197d48755\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 11:41:56 2013 +0900\n\+ \\n\+ \    Jhs does not support make -j?\n\+ \\n\+ \commit a41169ffc25083c5a6a8429956b237562ec2cdb3\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 11:31:45 2013 +0900\n\+ \\n\+ \    Add -j3 option for make command.\n\+ \\n\+ \commit b0f9637ea5617438058c187216d5ad924c7c87cb\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 11:15:40 2013 +0900\n\+ \\n\+ \    Need libconfig-yaml-perl to regress on travis-ci.\n\+ \\n\+ \commit 69a66d5f4faa8410ceed63845e51179e60fb9b29\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 11:00:16 2013 +0900\n\+ \\n\+ \    Do not use locales-all. It's not found on travis-ci.\n\+ \\n\+ \commit 6cbc218a48fd7b70d5743a6f3b0a78b287f583b7\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 10:54:42 2013 +0900\n\+ \\n\+ \    Write .travis.yml from scratch.\n\+ \\n\+ \commit 2fa490f923f444840ee1fc51bf0e2e378d3b989a\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 07:23:15 2013 +0900\n\+ \\n\+ \    Add regress target to Makefile.\n\+ \\n\+ \commit f1e72fd1bdfd1d78634d009471e0c76ae61f2f66\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 06:59:16 2013 +0900\n\+ \\n\+ \    Use autoconf on travis-ci.\n\+ \\n\+ \commit d80e701a15200d4958b98f0cb318347b6dd6f56f\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 06:42:01 2013 +0900\n\+ \\n\+ \    Add Travis CI setting file.\n\+ \\n\+ \commit 5892ff8176c0d5179e75ab4c27ea6f58ddc067b9\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date:   Sat Mar 2 02:44:13 2013 +0900\n\+ \\n\+ \    Add gitignore file. / Use git for darcs to dump Changelog.\n\+ \"#++-- | Generated from src\/data\/shortchange.txt+{-# NOINLINE shortchange_txt #-}+shortchange_txt :: ByteString+shortchange_txt = unsafePerformIO $ unsafePackAddress "\+ \f1bf6e4a473a42ac193097a84adebd6506b61209\+ \"#++-- | Generated from rts\/rts\/slub.c+{-# NOINLINE slub_c #-}+slub_c :: ByteString+slub_c = unsafePerformIO $ unsafePackAddress "\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \\n\+ \#ifdef JHC_HEADER\n\+ \\n\+ \struct s_arena;\n\+ \struct s_cache;\n\+ \static void *s_alloc(gc_t gc, struct s_cache *sc) A_UNUSED;\n\+ \static struct s_cache *find_cache(struct s_cache **rsc, struct s_arena *arena,\n\+ \                                  unsigned short size, unsigned short num_ptrs) A_UNUSED;\n\+ \static bool s_set_used_bit(void *val) A_UNUSED;\n\+ \static void clear_used_bits(struct s_arena *arena) A_UNUSED;\n\+ \\n\+ \#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~ (BLOCK_SIZE - 1)))\n\+ \#define BLOCK_SIZE     (1UL << 12)\n\+ \#define MEGABLOCK_SIZE (1UL << 20)\n\+ \\n\+ \#else\n\+ \\n\+ \#include \"sys/bitarray.h\"\n\+ \#include \"sys/queue.h\"\n\+ \\n\+ \struct s_arena {\n\+ \        struct s_megablock *current_megablock;\n\+ \        SLIST_HEAD(,s_block) free_blocks;\n\+ \        unsigned block_used;\n\+ \        unsigned block_threshold;\n\+ \        SLIST_HEAD(,s_cache) caches;\n\+ \        SLIST_HEAD(,s_megablock) megablocks;\n\+ \};\n\+ \\n\+ \struct s_megablock {\n\+ \        void *base;\n\+ \        unsigned next_free;\n\+ \        SLIST_ENTRY(s_megablock) next;\n\+ \};\n\+ \\n\+ \struct s_block_info {\n\+ \        unsigned char color;\n\+ \        unsigned char size;\n\+ \        unsigned char num_ptrs;\n\+ \        unsigned char flags;\n\+ \};\n\+ \\n\+ \struct s_block {\n\+ \        SLIST_ENTRY(s_block) link;\n\+ \        struct s_block_info pi;\n\+ \        unsigned short num_free;\n\+ \        unsigned short next_free;\n\+ \        bitarray_t used[];\n\+ \};\n\+ \\n\+ \struct s_cache {\n\+ \        SLIST_ENTRY(s_cache) next;\n\+ \        SLIST_HEAD(,s_block) blocks;\n\+ \        SLIST_HEAD(,s_block) full_blocks;\n\+ \        struct s_block_info pi;\n\+ \        unsigned short num_entries;\n\+ \        struct s_arena *arena;\n\+ \};\n\+ \\n\+ \/* This finds a bit that isn't set, sets it, then returns its index.  It\n\+ \ * assumes that a bit is available to be found, otherwise it goes into an\n\+ \ * infinite loop. */\n\+ \\n\+ \static unsigned\n\+ \bitset_find_free(unsigned *next_free,int n,bitarray_t ba[static n]) {\n\+ \        assert(*next_free < (unsigned)n);\n\+ \        unsigned i = *next_free;\n\+ \        do {\n\+ \                int o = __builtin_ffsl(~ba[i]);\n\+ \                if(__predict_true(o)) {\n\+ \                        ba[i] |= (1UL << (o - 1));\n\+ \                        *next_free = i;\n\+ \                        return (i*BITS_PER_UNIT + (o - 1));\n\+ \                }\n\+ \                i = (i + 1) % n;\n\+ \                assert(i != *next_free);\n\+ \        } while (1);\n\+ \}\n\+ \\n\+ \struct s_megablock *\n\+ \s_new_megablock(struct s_arena *arena)\n\+ \{\n\+ \        struct s_megablock *mb = malloc(sizeof(*mb));\n\+ \#if defined(__WIN32__)\n\+ \        mb->base = _aligned_malloc(MEGABLOCK_SIZE, BLOCK_SIZE);\n\+ \        int ret = !mb->base;\n\+ \#elif defined(__ARM_EABI__)\n\+ \        mb->base = memalign(BLOCK_SIZE,MEGABLOCK_SIZE);\n\+ \        int ret = !mb->base;\n\+ \#elif (defined(__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__) && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ <  1060)\n\+ \        assert(sysconf(_SC_PAGESIZE) == BLOCK_SIZE);\n\+ \        mb->base = valloc(MEGABLOCK_SIZE);\n\+ \        int ret = !mb->base;\n\+ \#else\n\+ \        int ret = posix_memalign(&mb->base,BLOCK_SIZE,MEGABLOCK_SIZE);\n\+ \#endif\n\+ \        if(ret != 0) {\n\+ \                fprintf(stderr,\"Unable to allocate memory for megablock\\n\");\n\+ \                abort();\n\+ \        }\n\+ \        VALGRIND_MAKE_MEM_NOACCESS(mb->base,MEGABLOCK_SIZE);\n\+ \        //VALGRIND_FREELIKE_BLOCK(mb->base,0);\n\+ \        mb->next_free = 0;\n\+ \        return mb;\n\+ \}\n\+ \\n\+ \/* block allocator */\n\+ \\n\+ \static struct s_block *\n\+ \get_free_block(gc_t gc, struct s_arena *arena) {\n\+ \        arena->block_used++;\n\+ \        if(__predict_true(SLIST_FIRST(&arena->free_blocks))) {\n\+ \                struct s_block *pg = SLIST_FIRST(&arena->free_blocks);\n\+ \                SLIST_REMOVE_HEAD(&arena->free_blocks,link);\n\+ \                return pg;\n\+ \        } else {\n\+ \                if((arena->block_used >= arena->block_threshold)) {\n\+ \                        gc_perform_gc(gc);\n\+ \                        // if we are still using 80% of the heap after a gc, raise the threshold.\n\+ \                        if(__predict_false((unsigned)arena->block_used * 10 >= arena->block_threshold * 9)) {\n\+ \                                arena->block_threshold *= 2;\n\+ \                        }\n\+ \                }\n\+ \                if(__predict_false(!arena->current_megablock))\n\+ \                        arena->current_megablock = s_new_megablock(arena);\n\+ \                struct s_megablock *mb = arena->current_megablock;\n\+ \                struct s_block *pg = mb->base + BLOCK_SIZE*mb->next_free;\n\+ \                mb->next_free++;\n\+ \                if(mb->next_free == MEGABLOCK_SIZE / BLOCK_SIZE) {\n\+ \                        SLIST_INSERT_HEAD(&arena->megablocks,mb, next);\n\+ \                        arena->current_megablock = NULL;\n\+ \                }\n\+ \                VALGRIND_MAKE_MEM_UNDEFINED(pg,sizeof(struct s_block));\n\+ \                pg->num_free = 0;\n\+ \                return pg;\n\+ \        }\n\+ \}\n\+ \\n\+ \static void\n\+ \s_cleanup_blocks(struct s_arena *arena) {\n\+ \        struct s_cache *sc = SLIST_FIRST(&arena->caches);\n\+ \        for(;sc;sc = SLIST_NEXT(sc,next)) {\n\+ \\n\+ \                // 'best' keeps track of the block with the fewest free spots\n\+ \                // and percolates it to the front, effectively a single pass\n\+ \                // of a bubblesort to help combat fragmentation. It does\n\+ \                // not increase the complexity of the cleanup algorithm as\n\+ \                // we had to scan every block anyway, but over many passes\n\+ \                // of the GC it will eventually result in a more sorted list\n\+ \                // than would occur by chance.\n\+ \\n\+ \                struct s_block *best = NULL;\n\+ \                int free_best = 4096;\n\+ \                struct s_block *pg = SLIST_FIRST(&sc->blocks);\n\+ \                struct s_block *fpg = SLIST_FIRST(&sc->full_blocks);\n\+ \                SLIST_INIT(&sc->blocks);\n\+ \                SLIST_INIT(&sc->full_blocks);\n\+ \                if(!pg) {\n\+ \                        pg = fpg;\n\+ \                        fpg = NULL;\n\+ \                }\n\+ \                while(pg) {\n\+ \                        struct s_block *npg = SLIST_NEXT(pg,link);\n\+ \                        if(__predict_false(pg->num_free == 0)) {\n\+ \                                SLIST_INSERT_HEAD(&sc->full_blocks,pg,link);\n\+ \                        } else if(__predict_true(pg->num_free == sc->num_entries)) {\n\+ \                                arena->block_used--;\n\+ \                                VALGRIND_MAKE_MEM_NOACCESS((char *)pg + sizeof(struct s_block), BLOCK_SIZE - sizeof(struct s_block));\n\+ \                                SLIST_INSERT_HEAD(&arena->free_blocks,pg,link);\n\+ \                        } else {\n\+ \                                if(!best) {\n\+ \                                        free_best = pg->num_free;\n\+ \                                        best = pg;\n\+ \                                } else {\n\+ \                                        if(pg->num_free < free_best) {\n\+ \                                                struct s_block *tmp = best;\n\+ \                                                best = pg; pg = tmp;\n\+ \                                                free_best = pg->num_free;\n\+ \                                        }\n\+ \                                        SLIST_INSERT_HEAD(&sc->blocks,pg,link);\n\+ \                                }\n\+ \                        }\n\+ \                        if(!npg && fpg) {\n\+ \                                pg = fpg;\n\+ \                                fpg = NULL;\n\+ \                        } else\n\+ \                                pg = npg;\n\+ \                }\n\+ \                if(best)\n\+ \                        SLIST_INSERT_HEAD(&sc->blocks,best,link);\n\+ \        }\n\+ \}\n\+ \\n\+ \inline static void\n\+ \clear_block_used_bits(unsigned num_entries, struct s_block *pg)\n\+ \{\n\+ \        pg->num_free = num_entries;\n\+ \        memset(pg->used,0,BITARRAY_SIZE_IN_BYTES(num_entries) - sizeof(pg->used[0]));\n\+ \        int excess = num_entries % BITS_PER_UNIT;\n\+ \        pg->used[BITARRAY_SIZE(num_entries) - 1] = ~((1UL << excess) - 1);\n\+ \#if JHC_VALGRIND\n\+ \                unsigned header =  sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(num_entries);\n\+ \                VALGRIND_MAKE_MEM_NOACCESS((char *)pg + header, BLOCK_SIZE - header);\n\+ \#endif\n\+ \}\n\+ \\n\+ \static void *\n\+ \s_alloc(gc_t gc, struct s_cache *sc)\n\+ \{\n\+ \        struct s_block *pg = SLIST_FIRST(&sc->blocks);\n\+ \        if(__predict_false(!pg)) {\n\+ \                pg = get_free_block(gc, sc->arena);\n\+ \                VALGRIND_MAKE_MEM_NOACCESS(pg, BLOCK_SIZE);\n\+ \                VALGRIND_MAKE_MEM_DEFINED(pg, sizeof(struct s_block));\n\+ \                if(sc->num_entries != pg->num_free)\n\+ \                        VALGRIND_MAKE_MEM_UNDEFINED((char *)pg->used,BITARRAY_SIZE_IN_BYTES(sc->num_entries));\n\+ \                else\n\+ \                        VALGRIND_MAKE_MEM_DEFINED((char *)pg->used,BITARRAY_SIZE_IN_BYTES(sc->num_entries));\n\+ \                assert(pg);\n\+ \                pg->pi = sc->pi;\n\+ \                pg->next_free = 0;\n\+ \                SLIST_INSERT_HEAD(&sc->blocks,pg,link);\n\+ \                if(sc->num_entries != pg->num_free)\n\+ \                        clear_block_used_bits(sc->num_entries, pg);\n\+ \                pg->used[0] = 1; //set the first bit\n\+ \                pg->num_free = sc->num_entries - 1;\n\+ \                return (uintptr_t *)pg + pg->pi.color;\n\+ \        } else {\n\+ \                __builtin_prefetch(pg->used,1);\n\+ \                pg->num_free--;\n\+ \                unsigned next_free = pg->next_free;\n\+ \                unsigned found = bitset_find_free(&next_free,BITARRAY_SIZE(sc->num_entries),pg->used);\n\+ \                pg->next_free = next_free;\n\+ \                void *val = (uintptr_t *)pg + pg->pi.color + found*pg->pi.size;\n\+ \                if(__predict_false(0 == pg->num_free)) {\n\+ \                        assert(pg == SLIST_FIRST(&sc->blocks));\n\+ \                        SLIST_REMOVE_HEAD(&sc->blocks,link);\n\+ \                        SLIST_INSERT_HEAD(&sc->full_blocks,pg,link);\n\+ \                }\n\+ \                assert(S_BLOCK(val) == pg);\n\+ \                //printf(\"s_alloc: val: %p s_block: %p size: %i color: %i found: %i num_free: %i\\n\", val, pg, pg->pi.size, pg->pi.color, found, pg->num_free);\n\+ \                return val;\n\+ \        }\n\+ \}\n\+ \\n\+ \/*\n\+ \static void\n\+ \s_free(void *val)\n\+ \{\n\+ \        assert(val);\n\+ \        struct s_block *pg = s_block(val);\n\+ \        unsigned int offset = ((uintptr_t *)val - (uintptr_t *)pg) - pg->pi.color;\n\+ \//        printf(\"s_free:  val: %p s_block: %p size: %i color: %i num_free: %i offset: %i bit: %i\\n\", val, pg, pg->pi.size, pg->pi.color, pg->num_free, offset, offset/pg->pi.size);\n\+ \        assert(BIT_VALUE(pg->used,offset/(pg->pi.size)));\n\+ \        BIT_UNSET(pg->used,offset/(pg->pi.size));\n\+ \        pg->num_free++;\n\+ \}\n\+ \*/\n\+ \\n\+ \static struct s_cache *\n\+ \new_cache(struct s_arena *arena, unsigned short size, unsigned short num_ptrs)\n\+ \{\n\+ \        struct s_cache *sc = malloc(sizeof(*sc));\n\+ \        sc->arena = arena;\n\+ \        sc->pi.size = size;\n\+ \        sc->pi.num_ptrs = num_ptrs;\n\+ \        sc->pi.flags = 0;\n\+ \        size_t excess = BLOCK_SIZE - sizeof(struct s_block);\n\+ \        sc->num_entries = (8*excess) / (8*sizeof(uintptr_t)*size + 1) - 1;\n\+ \        //sc->num_entries = (8*excess) / (8*size*sizeof(uintptr_t) + 1);\n\+ \        sc->pi.color = (sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(sc->num_entries) + sizeof(uintptr_t) - 1) / sizeof(uintptr_t);\n\+ \        SLIST_INIT(&sc->blocks);\n\+ \        SLIST_INIT(&sc->full_blocks);\n\+ \        SLIST_INSERT_HEAD(&arena->caches,sc,next);\n\+ \        //print_cache(sc);\n\+ \        return sc;\n\+ \}\n\+ \\n\+ \// clear all used bits, must be followed by a marking phase.\n\+ \static void\n\+ \clear_used_bits(struct s_arena *arena)\n\+ \{\n\+ \        struct s_cache *sc = SLIST_FIRST(&arena->caches);\n\+ \        for(;sc;sc = SLIST_NEXT(sc,next)) {\n\+ \                struct s_block *pg = SLIST_FIRST(&sc->blocks);\n\+ \                struct s_block *fpg = SLIST_FIRST(&sc->full_blocks);\n\+ \                do {\n\+ \                        for(;pg;pg = SLIST_NEXT(pg,link))\n\+ \                                clear_block_used_bits(sc->num_entries,pg);\n\+ \                        pg = fpg;\n\+ \                        fpg = NULL;\n\+ \                }  while(pg);\n\+ \        }\n\+ \}\n\+ \\n\+ \// set a used bit. returns true if the\n\+ \// tagged node should be scanned by the GC.\n\+ \// this happens when the used bit was not previously set\n\+ \// and the node contains internal pointers.\n\+ \\n\+ \static bool\n\+ \s_set_used_bit(void *val)\n\+ \{\n\+ \        assert(val);\n\+ \        struct s_block *pg = S_BLOCK(val);\n\+ \        unsigned int offset = ((uintptr_t *)val - (uintptr_t *)pg) - pg->pi.color;\n\+ \        if(__predict_true(BIT_IS_UNSET(pg->used,offset/pg->pi.size))) {\n\+ \                BIT_SET(pg->used,offset/pg->pi.size);\n\+ \                pg->num_free--;\n\+ \                return (bool)pg->pi.num_ptrs;\n\+ \        }\n\+ \        return false;\n\+ \}\n\+ \\n\+ \static struct s_cache *\n\+ \find_cache(struct s_cache **rsc, struct s_arena *arena, unsigned short size, unsigned short num_ptrs)\n\+ \{\n\+ \        if(__predict_true(rsc && *rsc))\n\+ \                return *rsc;\n\+ \        struct s_cache *sc = SLIST_FIRST(&arena->caches);\n\+ \        for(;sc;sc = SLIST_NEXT(sc,next)) {\n\+ \                if(sc->pi.size == size && sc->pi.num_ptrs == num_ptrs)\n\+ \                        goto found;\n\+ \        }\n\+ \        sc = new_cache(arena,size,num_ptrs);\n\+ \found:\n\+ \        if(rsc)\n\+ \                *rsc = sc;\n\+ \        return sc;\n\+ \}\n\+ \\n\+ \struct s_arena *\n\+ \new_arena(void) {\n\+ \        struct s_arena *arena = malloc(sizeof(struct s_arena));\n\+ \        SLIST_INIT(&arena->caches);\n\+ \        SLIST_INIT(&arena->free_blocks);\n\+ \        SLIST_INIT(&arena->megablocks);\n\+ \        arena->block_used = 0;\n\+ \        arena->block_threshold = 8;\n\+ \        arena->current_megablock = NULL;\n\+ \        return arena;\n\+ \}\n\+ \\n\+ \void\n\+ \print_cache(struct s_cache *sc) {\n\+ \        fprintf(stderr, \"num_entries: %i\\n\",(int)sc->num_entries);\n\+ \//        printf(\"  entries: %i words\\n\",(int)(sc->num_entries*sc->pi.size));\n\+ \        fprintf(stderr, \"  header: %lu bytes\\n\", sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(sc->num_entries));\n\+ \        fprintf(stderr, \"  size: %i words\\n\",(int)sc->pi.size);\n\+ \//        printf(\"  color: %i words\\n\",(int)sc->pi.color);\n\+ \        fprintf(stderr, \"  nptrs: %i words\\n\",(int)sc->pi.num_ptrs);\n\+ \//        printf(\"  end: %i bytes\\n\",(int)(sc->pi.color+ sc->num_entries*sc->pi.size)*sizeof(uintptr_t));\n\+ \        fprintf(stderr, \"%20s %9s %9s %s\\n\", \"block\", \"num_free\", \"next_free\", \"status\");\n\+ \        struct s_block *pg;\n\+ \        SLIST_FOREACH(pg,&sc->blocks,link) {\n\+ \            fprintf(stderr, \"%20p %9i %9i %c\\n\", pg, pg->num_free, pg->next_free, 'P');\n\+ \        }\n\+ \        fprintf(stderr, \"  full_blocks:\\n\");\n\+ \        SLIST_FOREACH(pg,&sc->full_blocks,link) {\n\+ \            fprintf(stderr, \"%20p %9i %9i %c\\n\", pg, pg->num_free, pg->next_free, 'F');\n\+ \        }\n\+ \}\n\+ \\n\+ \#endif\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/gc_jgc.c+{-# NOINLINE gc_jgc_c #-}+gc_jgc_c :: ByteString+gc_jgc_c = unsafePerformIO $ unsafePackAddress "\+ \#include \"jhc_rts_header.h\"\n\+ \#include \"sys/queue.h\"\n\+ \#include \"sys/bitarray.h\"\n\+ \#include \"rts/cdefs.h\"\n\+ \#include \"rts/constants.h\"\n\+ \#include \"rts/gc_jgc_internal.h\"\n\+ \\n\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \\n\+ \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\+ \static char aligned_megablock_1[MEGABLOCK_SIZE] __attribute__ ((aligned(BLOCK_SIZE)));\n\+ \static char gc_stack_base_area[(1UL << 8)*sizeof(gc_t)];\n\+ \#endif\n\+ \gc_t saved_gc;\n\+ \struct s_arena *arena;\n\+ \static gc_t gc_stack_base;\n\+ \\n\+ \#define TO_GCPTR(x) (entry_t *)(FROM_SPTR(x))\n\+ \\n\+ \void gc_perform_gc(gc_t gc) A_STD;\n\+ \static bool s_set_used_bit(void *val) A_UNUSED;\n\+ \static void clear_used_bits(struct s_arena *arena) A_UNUSED;\n\+ \static void s_cleanup_blocks(struct s_arena *arena);\n\+ \static struct s_block *get_free_block(gc_t gc, struct s_arena *arena);\n\+ \static void *jhc_aligned_alloc(unsigned size);\n\+ \\n\+ \typedef struct {\n\+ \        sptr_t ptrs[0];\n\+ \} entry_t;\n\+ \\n\+ \static const void *nh_start, *nh_end;\n\+ \\n\+ \static bool\n\+ \gc_check_heap(entry_t *s)\n\+ \{\n\+ \        return (s < (entry_t *)nh_start || s > (entry_t *)nh_end);\n\+ \}\n\+ \\n\+ \struct stack {\n\+ \        unsigned size;\n\+ \        unsigned ptr;\n\+ \        entry_t * *stack;\n\+ \};\n\+ \\n\+ \#define EMPTY_STACK { 0, 0, NULL }\n\+ \\n\+ \static void\n\+ \stack_grow(struct stack *s, unsigned grow)\n\+ \{\n\+ \        s->size += grow;\n\+ \        s->stack = realloc(s->stack, sizeof(s->stack[0])*s->size);\n\+ \        assert(s->stack);\n\+ \        debugf(\"stack:\");\n\+ \        for(unsigned i = 0; i < s->ptr; i++) {\n\+ \                debugf(\" %p\", (void *)s->stack[i]);\n\+ \        }\n\+ \        debugf(\"\\n\");\n\+ \}\n\+ \\n\+ \inline static void\n\+ \stack_check(struct stack *s, unsigned n) {\n\+ \        if(__predict_false(s->size - s->ptr < n)) {\n\+ \#ifndef _JHC_JGC_STACKGROW\n\+ \#define _JHC_JGC_STACKGROW (1024)\n\+ \#endif\n\+ \                stack_grow(s,n + (_JHC_JGC_STACKGROW));\n\+ \        }\n\+ \}\n\+ \\n\+ \static struct stack root_stack = EMPTY_STACK;\n\+ \\n\+ \void gc_add_root(gc_t gc, void *root)\n\+ \{\n\+ \        if(IS_PTR(root)) {\n\+ \                entry_t *nroot = TO_GCPTR(root);\n\+ \                if(gc_check_heap(nroot)) {\n\+ \                        stack_check(&root_stack,1);\n\+ \                        root_stack.stack[root_stack.ptr++] = nroot;\n\+ \                }\n\+ \        }\n\+ \}\n\+ \\n\+ \static void\n\+ \gc_add_grey(struct stack *stack, entry_t *s)\n\+ \{\n\+ \        VALGRIND_MAKE_MEM_DEFINED(s,(S_BLOCK(s))->u.pi.size * sizeof(uintptr_t));\n\+ \        if(gc_check_heap(s) && s_set_used_bit(s))\n\+ \                stack->stack[stack->ptr++] = s;\n\+ \}\n\+ \\n\+ \void A_STD\n\+ \gc_perform_gc(gc_t gc)\n\+ \{\n\+ \        profile_push(&gc_gc_time);\n\+ \        arena->number_gcs++;\n\+ \\n\+ \        unsigned number_redirects = 0;\n\+ \        unsigned number_stack = 0;\n\+ \        unsigned number_ptr = 0;\n\+ \        struct stack stack = EMPTY_STACK;\n\+ \\n\+ \        clear_used_bits(arena);\n\+ \\n\+ \        debugf(\"Setting Roots:\");\n\+ \        stack_check(&stack, root_stack.ptr);\n\+ \        for(unsigned i = 0; i < root_stack.ptr; i++) {\n\+ \                gc_add_grey(&stack, root_stack.stack[i]);\n\+ \                debugf(\" %p\", root_stack.stack[i]);\n\+ \        }\n\+ \        debugf(\" # \");\n\+ \        struct StablePtr *sp;\n\+ \        LIST_FOREACH(sp, &root_StablePtrs, link) {\n\+ \            gc_add_grey(&stack, (entry_t *)sp);\n\+ \            debugf(\" %p\", root_stack.stack[i]);\n\+ \        }\n\+ \\n\+ \        debugf(\"\\n\");\n\+ \        debugf(\"Trace:\");\n\+ \        stack_check(&stack, gc - gc_stack_base);\n\+ \        number_stack = gc - gc_stack_base;\n\+ \        for(unsigned i = 0; i < number_stack; i++) {\n\+ \                debugf(\" |\");\n\+ \                // TODO - short circuit redirects on stack\n\+ \                sptr_t ptr = gc_stack_base[i];\n\+ \                if(1 && (IS_LAZY(ptr))) {\n\+ \                        assert(GET_PTYPE(ptr) == P_LAZY);\n\+ \                        VALGRIND_MAKE_MEM_DEFINED(FROM_SPTR(ptr), sizeof(uintptr_t));\n\+ \                        if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) {\n\+ \                                void *gptr = TO_GCPTR(ptr);\n\+ \                                if(gc_check_heap(gptr))\n\+ \                                        s_set_used_bit(gptr);\n\+ \                                number_redirects++;\n\+ \                                debugf(\" *\");\n\+ \                                ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr));\n\+ \                        }\n\+ \                }\n\+ \                if(__predict_false(!IS_PTR(ptr))) {\n\+ \                        debugf(\" -\");\n\+ \                        continue;\n\+ \                }\n\+ \                number_ptr++;\n\+ \                entry_t *e = TO_GCPTR(ptr);\n\+ \                debugf(\" %p\",(void *)e);\n\+ \                gc_add_grey(&stack, e);\n\+ \        }\n\+ \        debugf(\"\\n\");\n\+ \\n\+ \        while(stack.ptr) {\n\+ \                entry_t *e = stack.stack[--stack.ptr];\n\+ \                struct s_block *pg = S_BLOCK(e);\n\+ \                if(!(pg->flags & SLAB_MONOLITH))\n\+ \                        VALGRIND_MAKE_MEM_DEFINED(e,pg->u.pi.size * sizeof(uintptr_t));\n\+ \                debugf(\"Processing Grey: %p\\n\",e);\n\+ \                unsigned num_ptrs = pg->flags & SLAB_MONOLITH ? pg->u.m.num_ptrs : pg->u.pi.num_ptrs;\n\+ \                stack_check(&stack, num_ptrs);\n\+ \                for(unsigned i = 0; i < num_ptrs; i++) {\n\+ \                        if(1 && (P_LAZY == GET_PTYPE(e->ptrs[i]))) {\n\+ \                                VALGRIND_MAKE_MEM_DEFINED(FROM_SPTR(e->ptrs[i]), sizeof(uintptr_t));\n\+ \                                if(!IS_LAZY(GETHEAD(FROM_SPTR(e->ptrs[i])))) {\n\+ \                                        number_redirects++;\n\+ \                                        debugf(\" *\");\n\+ \                                        e->ptrs[i] = (sptr_t)GETHEAD(FROM_SPTR(e->ptrs[i]));\n\+ \                                }\n\+ \                        }\n\+ \                        if(IS_PTR(e->ptrs[i])) {\n\+ \                                entry_t * ptr = TO_GCPTR(e->ptrs[i]);\n\+ \                                debugf(\"Following: %p %p\\n\",e->ptrs[i], ptr);\n\+ \                                gc_add_grey( &stack, ptr);\n\+ \                        }\n\+ \                }\n\+ \        }\n\+ \        free(stack.stack);\n\+ \        s_cleanup_blocks(arena);\n\+ \        if (JHC_STATUS) {\n\+ \                fprintf(stderr, \"%3u - %6u Used: %4u Thresh: %4u Ss: %5u Ps: %5u Rs: %5u Root: %3u\\n\",\n\+ \                        arena->number_gcs,\n\+ \                        arena->number_allocs,\n\+ \                        (unsigned)arena->block_used,\n\+ \                        (unsigned)arena->block_threshold,\n\+ \                        number_stack,\n\+ \                        number_ptr,\n\+ \                        number_redirects,\n\+ \                        (unsigned)root_stack.ptr\n\+ \                       );\n\+ \                arena->number_allocs = 0;\n\+ \        }\n\+ \        profile_pop(&gc_gc_time);\n\+ \}\n\+ \\n\+ \// 7 to share caches with the first 7 tuples\n\+ \#define GC_STATIC_ARRAY_NUM 7\n\+ \#define GC_MAX_BLOCK_ENTRIES 150\n\+ \\n\+ \static struct s_cache *array_caches[GC_STATIC_ARRAY_NUM];\n\+ \static struct s_cache *array_caches_atomic[GC_STATIC_ARRAY_NUM];\n\+ \\n\+ \void\n\+ \jhc_alloc_init(void) {\n\+ \        VALGRIND_PRINTF(\"Jhc-Valgrind mode active.\\n\");\n\+ \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\+ \        saved_gc = gc_stack_base = (void *) gc_stack_base_area;\n\+ \#else\n\+ \        saved_gc = gc_stack_base = malloc((1UL << 18)*sizeof(gc_stack_base[0]));\n\+ \#endif\n\+ \        arena = new_arena();\n\+ \        if(nh_stuff[0]) {\n\+ \                nh_end = nh_start = nh_stuff[0];\n\+ \                for(int i = 1; nh_stuff[i]; i++) {\n\+ \                        if(nh_stuff[i] < nh_start)\n\+ \                                nh_start = nh_stuff[i];\n\+ \                        if(nh_stuff[i] > nh_end)\n\+ \                                nh_end = nh_stuff[i];\n\+ \                }\n\+ \        }\n\+ \        for (int i = 0; i < GC_STATIC_ARRAY_NUM; i++) {\n\+ \                find_cache(&array_caches[i], arena, i + 1, i + 1);\n\+ \                find_cache(&array_caches_atomic[i], arena, i + 1, 0);\n\+ \        }\n\+ \}\n\+ \\n\+ \void\n\+ \jhc_alloc_fini(void) {\n\+ \        if(_JHC_PROFILE || JHC_STATUS) {\n\+ \                fprintf(stderr, \"arena: %p\\n\", arena);\n\+ \                fprintf(stderr, \"  block_used: %i\\n\", arena->block_used);\n\+ \                fprintf(stderr, \"  block_threshold: %i\\n\", arena->block_threshold);\n\+ \                struct s_cache *sc;\n\+ \                SLIST_FOREACH(sc,&arena->caches,next)\n\+ \                        print_cache(sc);\n\+ \        }\n\+ \}\n\+ \\n\+ \heap_t A_STD\n\+ \(gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs)\n\+ \{\n\+ \        assert(nptrs <= count);\n\+ \        entry_t *e = s_alloc(gc, find_cache(sc, arena, count, nptrs));\n\+ \        VALGRIND_MAKE_MEM_UNDEFINED(e,sizeof(uintptr_t)*count);\n\+ \        debugf(\"gc_alloc: %p %i %i\\n\",(void *)e, count, nptrs);\n\+ \        return (void *)e;\n\+ \}\n\+ \\n\+ \static heap_t A_STD\n\+ \s_monoblock(struct s_arena *arena, unsigned size, unsigned nptrs, unsigned flags) {\n\+ \        struct s_block *b = jhc_aligned_alloc(size * sizeof(uintptr_t));\n\+ \        b->flags = flags | SLAB_MONOLITH;\n\+ \        b->color = (sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(1) +\n\+ \                    sizeof(uintptr_t) - 1) / sizeof(uintptr_t);\n\+ \        b->u.m.num_ptrs = nptrs;\n\+ \        SLIST_INSERT_HEAD(&arena->monolithic_blocks, b, link);\n\+ \        b->used[0] = 1;\n\+ \        return (void *)b + b->color*sizeof(uintptr_t);\n\+ \}\n\+ \\n\+ \// Allocate an array of count garbage collectable locations in the garbage\n\+ \// collected heap.\n\+ \heap_t A_STD\n\+ \gc_array_alloc(gc_t gc, unsigned count)\n\+ \{\n\+ \        if (!count)\n\+ \               return NULL;\n\+ \        if (count <= GC_STATIC_ARRAY_NUM)\n\+ \                return (wptr_t)s_alloc(gc,array_caches[count - 1]);\n\+ \        if (count < GC_MAX_BLOCK_ENTRIES)\n\+ \                return s_alloc(gc, find_cache(NULL, arena, count, count));\n\+ \        return s_monoblock(arena, count, count, 0);\n\+ \        abort();\n\+ \}\n\+ \\n\+ \// Allocate an array of count non-garbage collectable locations in the garbage\n\+ \// collected heap.\n\+ \heap_t A_STD\n\+ \gc_array_alloc_atomic(gc_t gc, unsigned count, unsigned flags)\n\+ \{\n\+ \        if (!count)\n\+ \               return NULL;\n\+ \        if (count <= GC_STATIC_ARRAY_NUM && !flags)\n\+ \                return (wptr_t)s_alloc(gc,array_caches_atomic[count - 1]);\n\+ \        if (count < GC_MAX_BLOCK_ENTRIES && !flags)\n\+ \                return s_alloc(gc, find_cache(NULL, arena, count, 0));\n\+ \        return s_monoblock(arena, count, count, flags);\n\+ \        abort();\n\+ \}\n\+ \\n\+ \/* This finds a bit that isn't set, sets it, then returns its index.  It\n\+ \ * assumes that a bit is available to be found, otherwise it goes into an\n\+ \ * infinite loop. */\n\+ \\n\+ \static unsigned\n\+ \bitset_find_free(unsigned *next_free,int n,bitarray_t ba[static n]) {\n\+ \        assert(*next_free < (unsigned)n);\n\+ \        unsigned i = *next_free;\n\+ \        do {\n\+ \                int o = __builtin_ffsl(~ba[i]);\n\+ \                if(__predict_true(o)) {\n\+ \                        ba[i] |= (1UL << (o - 1));\n\+ \                        *next_free = i;\n\+ \                        return (i*BITS_PER_UNIT + (o - 1));\n\+ \                }\n\+ \                i = (i + 1) % n;\n\+ \                assert(i != *next_free);\n\+ \        } while (1);\n\+ \}\n\+ \\n\+ \static void *\n\+ \jhc_aligned_alloc(unsigned size) {\n\+ \        void *base;\n\+ \#if defined(__WIN32__)\n\+ \        base = _aligned_malloc(MEGABLOCK_SIZE, BLOCK_SIZE);\n\+ \        int ret = !base;\n\+ \#elif defined(__ARM_EABI__)\n\+ \        base = memalign(BLOCK_SIZE, MEGABLOCK_SIZE);\n\+ \        int ret = !base;\n\+ \#elif (defined(__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__) && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ <  1060)\n\+ \        assert(sysconf(_SC_PAGESIZE) == BLOCK_SIZE);\n\+ \        base = valloc(MEGABLOCK_SIZE);\n\+ \        int ret = !base;\n\+ \#else\n\+ \        int ret = posix_memalign(&base,BLOCK_SIZE,MEGABLOCK_SIZE);\n\+ \#endif\n\+ \        if(ret != 0) {\n\+ \                fprintf(stderr,\"Unable to allocate memory for aligned alloc: %u\\n\", size);\n\+ \                abort();\n\+ \        }\n\+ \        return base;\n\+ \}\n\+ \\n\+ \struct s_megablock *\n\+ \s_new_megablock(struct s_arena *arena)\n\+ \{\n\+ \        struct s_megablock *mb = malloc(sizeof(*mb));\n\+ \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\+ \        static int count = 0;\n\+ \        if (count != 0) {\n\+ \                abort();\n\+ \        }\n\+ \        count++;\n\+ \        mb->base = aligned_megablock_1;\n\+ \#else\n\+ \        mb->base = jhc_aligned_alloc(MEGABLOCK_SIZE);\n\+ \#endif\n\+ \        VALGRIND_MAKE_MEM_NOACCESS(mb->base,MEGABLOCK_SIZE);\n\+ \        mb->next_free = 0;\n\+ \        return mb;\n\+ \}\n\+ \\n\+ \/* block allocator */\n\+ \\n\+ \static struct s_block *\n\+ \get_free_block(gc_t gc, struct s_arena *arena) {\n\+ \        arena->block_used++;\n\+ \        if(__predict_true(SLIST_FIRST(&arena->free_blocks))) {\n\+ \                struct s_block *pg = SLIST_FIRST(&arena->free_blocks);\n\+ \                SLIST_REMOVE_HEAD(&arena->free_blocks,link);\n\+ \                return pg;\n\+ \        } else {\n\+ \#ifndef _JHC_JGC_NAIVEGC\n\+ \                if((arena->block_used >= arena->block_threshold)) {\n\+ \                        gc_perform_gc(gc);\n\+ \                        // if we are still using 80% of the heap after a gc, raise the threshold.\n\+ \                        if(__predict_false((unsigned)arena->block_used * 10 >= arena->block_threshold * 9)) {\n\+ \                                arena->block_threshold *= 2;\n\+ \                        }\n\+ \                }\n\+ \#endif\n\+ \                if(__predict_false(!arena->current_megablock))\n\+ \                        arena->current_megablock = s_new_megablock(arena);\n\+ \                struct s_megablock *mb = arena->current_megablock;\n\+ \                struct s_block *pg = mb->base + BLOCK_SIZE*mb->next_free;\n\+ \                mb->next_free++;\n\+ \                if(mb->next_free == MEGABLOCK_SIZE / BLOCK_SIZE) {\n\+ \                        SLIST_INSERT_HEAD(&arena->megablocks,mb, next);\n\+ \                        arena->current_megablock = NULL;\n\+ \                }\n\+ \                VALGRIND_MAKE_MEM_UNDEFINED(pg,sizeof(struct s_block));\n\+ \                pg->u.pi.num_free = 0;\n\+ \                return pg;\n\+ \        }\n\+ \}\n\+ \\n\+ \typedef void (*finalizer_ptr)(HsPtr arg);\n\+ \typedef void (*finalizer_env_ptr)(HsPtr env, HsPtr arg);\n\+ \\n\+ \void hs_foreignptr_env_helper(HsPtr env, HsPtr arg) {\n\+ \        ((finalizer_ptr)env)(arg);\n\+ \}\n\+ \\n\+ \static void\n\+ \s_cleanup_blocks(struct s_arena *arena) {\n\+ \        struct s_block *pg = SLIST_FIRST(&arena->monolithic_blocks);\n\+ \        SLIST_INIT(&arena->monolithic_blocks);\n\+ \        while (pg) {\n\+ \                if (pg->used[0]) {\n\+ \                        SLIST_INSERT_HEAD(&arena->monolithic_blocks, pg, link);\n\+ \                        pg = SLIST_NEXT(pg,link);\n\+ \                } else {\n\+ \                        if (pg->flags & SLAB_FLAG_FINALIZER) {\n\+ \                                HsPtr *ptr = (HsPtr *)pg;\n\+ \                                if(ptr[pg->color + 1]) {\n\+ \                                        finalizer_ptr *fp = ptr[pg->color + 1];\n\+ \                                        do {\n\+ \                                                fp[0](ptr[pg->color]);\n\+ \                                        } while(*++fp);\n\+ \                                }\n\+ \                        }\n\+ \                        void *ptr = pg;\n\+ \                        pg = SLIST_NEXT(pg,link);\n\+ \                        free(ptr);\n\+ \                }\n\+ \        }\n\+ \        struct s_cache *sc = SLIST_FIRST(&arena->caches);\n\+ \        for(;sc;sc = SLIST_NEXT(sc,next)) {\n\+ \                // 'best' keeps track of the block with the fewest free spots\n\+ \                // and percolates it to the front, effectively a single pass\n\+ \                // of a bubblesort to help combat fragmentation. It does\n\+ \                // not increase the complexity of the cleanup algorithm as\n\+ \                // we had to scan every block anyway, but over many passes\n\+ \                // of the GC it will eventually result in a more sorted list\n\+ \                // than would occur by chance.\n\+ \\n\+ \                struct s_block *best = NULL;\n\+ \                int free_best = 4096;\n\+ \                pg = SLIST_FIRST(&sc->blocks);\n\+ \                struct s_block *fpg = SLIST_FIRST(&sc->full_blocks);\n\+ \                SLIST_INIT(&sc->blocks);\n\+ \                SLIST_INIT(&sc->full_blocks);\n\+ \                if(!pg) {\n\+ \                        pg = fpg;\n\+ \                        fpg = NULL;\n\+ \                }\n\+ \                while(pg) {\n\+ \                        struct s_block *npg = SLIST_NEXT(pg,link);\n\+ \                        if(__predict_false(pg->u.pi.num_free == 0)) {\n\+ \                                // Add full blockes to the cache's full block list.\n\+ \                                SLIST_INSERT_HEAD(&sc->full_blocks,pg,link);\n\+ \                        } else if(__predict_true(pg->u.pi.num_free == sc->num_entries)) {\n\+ \                                // Return completely free block to arena free block list.\n\+ \                                arena->block_used--;\n\+ \                                VALGRIND_MAKE_MEM_NOACCESS((char *)pg + sizeof(struct s_block),\n\+ \                                                           BLOCK_SIZE - sizeof(struct s_block));\n\+ \                                SLIST_INSERT_HEAD(&arena->free_blocks,pg,link);\n\+ \                        } else {\n\+ \                                if(!best) {\n\+ \                                        free_best = pg->u.pi.num_free;\n\+ \                                        best = pg;\n\+ \                                } else {\n\+ \                                        if(pg->u.pi.num_free < free_best) {\n\+ \                                                struct s_block *tmp = best;\n\+ \                                                best = pg; pg = tmp;\n\+ \                                                free_best = pg->u.pi.num_free;\n\+ \                                        }\n\+ \                                        SLIST_INSERT_HEAD(&sc->blocks,pg,link);\n\+ \                                }\n\+ \                        }\n\+ \                        if(!npg && fpg) {\n\+ \                                pg = fpg;\n\+ \                                fpg = NULL;\n\+ \                        } else\n\+ \                                pg = npg;\n\+ \                }\n\+ \                if(best)\n\+ \                        SLIST_INSERT_HEAD(&sc->blocks,best,link);\n\+ \        }\n\+ \}\n\+ \\n\+ \inline static void\n\+ \clear_block_used_bits(unsigned num_entries, struct s_block *pg)\n\+ \{\n\+ \        pg->u.pi.num_free = num_entries;\n\+ \        memset(pg->used,0,BITARRAY_SIZE_IN_BYTES(num_entries) - sizeof(pg->used[0]));\n\+ \        int excess = num_entries % BITS_PER_UNIT;\n\+ \        pg->used[BITARRAY_SIZE(num_entries) - 1] = ~((1UL << excess) - 1);\n\+ \#if JHC_VALGRIND\n\+ \                unsigned header =  sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(num_entries);\n\+ \                VALGRIND_MAKE_MEM_NOACCESS((char *)pg + header, BLOCK_SIZE - header);\n\+ \#endif\n\+ \}\n\+ \\n\+ \/*\n\+ \ * allocators\n\+ \ */\n\+ \\n\+ \heap_t A_STD\n\+ \s_alloc(gc_t gc, struct s_cache *sc)\n\+ \{\n\+ \#if _JHC_PROFILE\n\+ \       sc->allocations++;\n\+ \       sc->arena->number_allocs++;\n\+ \#endif\n\+ \        struct s_block *pg = SLIST_FIRST(&sc->blocks);\n\+ \#ifdef _JHC_JGC_NAIVEGC\n\+ \        if(__predict_false(!pg)) {\n\+ \                gc_perform_gc(gc);\n\+ \                pg = SLIST_FIRST(&sc->blocks);\n\+ \        }\n\+ \#endif\n\+ \        if(__predict_false(!pg)) {\n\+ \                pg = get_free_block(gc, sc->arena);\n\+ \                VALGRIND_MAKE_MEM_NOACCESS(pg, BLOCK_SIZE);\n\+ \                VALGRIND_MAKE_MEM_DEFINED(pg, sizeof(struct s_block));\n\+ \                if(sc->num_entries != pg->u.pi.num_free)\n\+ \                        VALGRIND_MAKE_MEM_UNDEFINED((char *)pg->used,\n\+ \                                                    BITARRAY_SIZE_IN_BYTES(sc->num_entries));\n\+ \                else\n\+ \                        VALGRIND_MAKE_MEM_DEFINED((char *)pg->used,\n\+ \                                                  BITARRAY_SIZE_IN_BYTES(sc->num_entries));\n\+ \                assert(pg);\n\+ \                pg->flags = sc->flags;\n\+ \                pg->color = sc->color;\n\+ \                pg->u.pi.num_ptrs = sc->num_ptrs;\n\+ \                pg->u.pi.size = sc->size;\n\+ \                pg->u.pi.next_free = 0;\n\+ \                SLIST_INSERT_HEAD(&sc->blocks,pg,link);\n\+ \                if(sc->num_entries != pg->u.pi.num_free)\n\+ \                        clear_block_used_bits(sc->num_entries, pg);\n\+ \                pg->used[0] = 1; //set the first bit\n\+ \                pg->u.pi.num_free = sc->num_entries - 1;\n\+ \                return (uintptr_t *)pg + pg->color;\n\+ \        } else {\n\+ \                __builtin_prefetch(pg->used,1);\n\+ \                pg->u.pi.num_free--;\n\+ \                unsigned next_free = pg->u.pi.next_free;\n\+ \                unsigned found = bitset_find_free(&next_free,BITARRAY_SIZE(sc->num_entries),pg->used);\n\+ \                pg->u.pi.next_free = next_free;\n\+ \                void *val = (uintptr_t *)pg + pg->color + found*pg->u.pi.size;\n\+ \                if(__predict_false(0 == pg->u.pi.num_free)) {\n\+ \                        assert(pg == SLIST_FIRST(&sc->blocks));\n\+ \                        SLIST_REMOVE_HEAD(&sc->blocks,link);\n\+ \                        SLIST_INSERT_HEAD(&sc->full_blocks,pg,link);\n\+ \                }\n\+ \                assert(S_BLOCK(val) == pg);\n\+ \                //printf(\"s_alloc: val: %p s_block: %p size: %i color: %i found: %i num_free: %i\\n\", val, pg, pg->pi.size, pg->pi.color, found, pg->num_free);\n\+ \                return val;\n\+ \        }\n\+ \}\n\+ \\n\+ \struct s_cache *\n\+ \new_cache(struct s_arena *arena, unsigned short size, unsigned short num_ptrs)\n\+ \{\n\+ \        struct s_cache *sc = malloc(sizeof(*sc));\n\+ \        memset(sc,0,sizeof(*sc));\n\+ \        sc->arena = arena;\n\+ \        sc->size = size;\n\+ \        sc->num_ptrs = num_ptrs;\n\+ \        sc->flags = 0;\n\+ \        size_t excess = BLOCK_SIZE - sizeof(struct s_block);\n\+ \        sc->num_entries = (8*excess) / (8*sizeof(uintptr_t)*size + 1) - 1;\n\+ \        sc->color = (sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(sc->num_entries) +\n\+ \                        sizeof(uintptr_t) - 1) / sizeof(uintptr_t);\n\+ \        SLIST_INIT(&sc->blocks);\n\+ \        SLIST_INIT(&sc->full_blocks);\n\+ \        SLIST_INSERT_HEAD(&arena->caches,sc,next);\n\+ \        return sc;\n\+ \}\n\+ \\n\+ \// clear all used bits, must be followed by a marking phase.\n\+ \static void\n\+ \clear_used_bits(struct s_arena *arena)\n\+ \{\n\+ \        struct s_block *pg;\n\+ \        SLIST_FOREACH(pg, &arena->monolithic_blocks, link)\n\+ \            pg->used[0] = 0;\n\+ \        struct s_cache *sc = SLIST_FIRST(&arena->caches);\n\+ \        for(;sc;sc = SLIST_NEXT(sc,next)) {\n\+ \                SLIST_FOREACH(pg, &sc->blocks, link)\n\+ \                    clear_block_used_bits(sc->num_entries,pg);\n\+ \                SLIST_FOREACH(pg, &sc->full_blocks, link)\n\+ \                    clear_block_used_bits(sc->num_entries,pg);\n\+ \        }\n\+ \}\n\+ \\n\+ \// Set a used bit. returns true if the tagged node should be scanned by the GC.\n\+ \// this happens when the used bit was not previously set and the node contains\n\+ \// internal pointers.\n\+ \\n\+ \static bool\n\+ \s_set_used_bit(void *val)\n\+ \{\n\+ \        assert(val);\n\+ \        struct s_block *pg = S_BLOCK(val);\n\+ \        unsigned int offset = ((uintptr_t *)val - (uintptr_t *)pg) - pg->color;\n\+ \        if(__predict_true(BIT_IS_UNSET(pg->used,offset/pg->u.pi.size))) {\n\+ \                if (pg->flags & SLAB_MONOLITH) {\n\+ \                        pg->used[0] = 1;\n\+ \                        return (bool)pg->u.m.num_ptrs;\n\+ \\n\+ \                } else {\n\+ \                        BIT_SET(pg->used,offset/pg->u.pi.size);\n\+ \                        pg->u.pi.num_free--;\n\+ \                        return (bool)pg->u.pi.num_ptrs;\n\+ \                }\n\+ \        }\n\+ \        return false;\n\+ \}\n\+ \\n\+ \struct s_cache *\n\+ \find_cache(struct s_cache **rsc, struct s_arena *arena,\n\+ \           unsigned short size, unsigned short num_ptrs)\n\+ \{\n\+ \        if(__predict_true(rsc && *rsc))\n\+ \                return *rsc;\n\+ \        struct s_cache *sc = SLIST_FIRST(&arena->caches);\n\+ \        for(;sc;sc = SLIST_NEXT(sc,next)) {\n\+ \                if(sc->size == size && sc->num_ptrs == num_ptrs)\n\+ \                        goto found;\n\+ \        }\n\+ \        sc = new_cache(arena,size,num_ptrs);\n\+ \found:\n\+ \        if(rsc)\n\+ \                *rsc = sc;\n\+ \        return sc;\n\+ \}\n\+ \\n\+ \struct s_arena *\n\+ \new_arena(void) {\n\+ \        struct s_arena *arena = malloc(sizeof(struct s_arena));\n\+ \        SLIST_INIT(&arena->caches);\n\+ \        SLIST_INIT(&arena->free_blocks);\n\+ \        SLIST_INIT(&arena->megablocks);\n\+ \        SLIST_INIT(&arena->monolithic_blocks);\n\+ \        arena->block_used = 0;\n\+ \        arena->block_threshold = 8;\n\+ \        arena->current_megablock = NULL;\n\+ \        return arena;\n\+ \}\n\+ \\n\+ \uint32_t\n\+ \get_heap_flags(void * sp) {\n\+ \        uint32_t ret = 0;\n\+ \        switch (GET_PTYPE(sp)) {\n\+ \        case P_VALUE: return SLAB_VIRTUAL_VALUE;\n\+ \        case P_FUNC: return SLAB_VIRTUAL_FUNC;\n\+ \        case P_LAZY:\n\+ \                     ret |= SLAB_VIRTUAL_LAZY;\n\+ \        case P_WHNF:\n\+ \                     if (S_BLOCK(sp) == NULL)\n\+ \                             return (ret | SLAB_VIRTUAL_SPECIAL);\n\+ \                     if ((void *)sp >= nh_start && (void *)sp <= nh_end)\n\+ \                             return (ret | SLAB_VIRTUAL_CONSTANT);\n\+ \                     return ret |= S_BLOCK(sp)->flags;\n\+ \        }\n\+ \        return ret;\n\+ \}\n\+ \\n\+ \heap_t A_STD\n\+ \gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) {\n\+ \        // we don't allow higher alignments yet.\n\+ \        assert (alignment <= sizeof(uintptr_t));\n\+ \        // no finalizers yet\n\+ \        assert (!finalizer);\n\+ \        unsigned spacing = 1 + finalizer;\n\+ \        wptr_t *res = gc_array_alloc_atomic(saved_gc, spacing + TO_BLOCKS(size),\n\+ \                                             finalizer ? SLAB_FLAG_FINALIZER : SLAB_FLAG_NONE);\n\+ \        res[0] = (wptr_t)(res + spacing);\n\+ \        if (finalizer)\n\+ \                res[1] = NULL;\n\+ \        return TO_SPTR(P_WHNF, res);\n\+ \}\n\+ \\n\+ \heap_t A_STD\n\+ \gc_new_foreignptr(HsPtr ptr) {\n\+ \        HsPtr *res = gc_array_alloc_atomic(saved_gc, 2, SLAB_FLAG_FINALIZER);\n\+ \        res[0] = ptr;\n\+ \        res[1] = NULL;\n\+ \        return TO_SPTR(P_WHNF, res);\n\+ \}\n\+ \\n\+ \bool A_STD\n\+ \gc_add_foreignptr_finalizer(wptr_t fp, HsFunPtr finalizer) {\n\+ \        if (!(SLAB_FLAG_FINALIZER & get_heap_flags(fp)))\n\+ \                return false;\n\+ \        HsFunPtr **res = (HsFunPtr**)FROM_SPTR(fp);\n\+ \        unsigned len = 0;\n\+ \        if (res[1])\n\+ \                while(res[1][len++]);\n\+ \        else\n\+ \                len = 1;\n\+ \        res[1] = realloc(res[1], (len + 1) * sizeof(HsFunPtr));\n\+ \        HsFunPtr *ptrs = res[1];\n\+ \        ptrs[len - 1] = finalizer;\n\+ \        ptrs[len] = NULL;\n\+ \        return true;\n\+ \}\n\+ \\n\+ \void\n\+ \print_cache(struct s_cache *sc) {\n\+ \        fprintf(stderr, \"num_entries: %i with %lu bytes of header\\n\",\n\+ \                (int)sc->num_entries, sizeof(struct s_block) +\n\+ \                BITARRAY_SIZE_IN_BYTES(sc->num_entries));\n\+ \        fprintf(stderr, \"  size: %i words %i ptrs\\n\",\n\+ \                (int)sc->size,(int)sc->num_ptrs);\n\+ \#if _JHC_PROFILE\n\+ \        fprintf(stderr, \"  allocations: %lu\\n\", (unsigned long)sc->allocations);\n\+ \#endif\n\+ \        if(SLIST_EMPTY(&sc->blocks) && SLIST_EMPTY(&sc->full_blocks))\n\+ \                return;\n\+ \        fprintf(stderr, \"  blocks:\\n\");\n\+ \        fprintf(stderr, \"%20s %9s %9s %s\\n\", \"block\", \"num_free\", \"next_free\", \"status\");\n\+ \        struct s_block *pg;\n\+ \        SLIST_FOREACH(pg,&sc->blocks,link)\n\+ \            fprintf(stderr, \"%20p %9i %9i %c\\n\", pg, pg->u.pi.num_free, pg->u.pi.next_free, 'P');\n\+ \        SLIST_FOREACH(pg,&sc->full_blocks,link)\n\+ \            fprintf(stderr, \"%20p %9i %9i %c\\n\", pg, pg->u.pi.num_free, pg->u.pi.next_free, 'F');\n\+ \}\n\+ \\n\+ \void hs_perform_gc(void) {\n\+ \        gc_perform_gc(saved_gc);\n\+ \}\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/gc_jgc.h+{-# NOINLINE gc_jgc_h #-}+gc_jgc_h :: ByteString+gc_jgc_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef JHC_GC_JGC_H\n\+ \#define JHC_GC_JGC_H\n\+ \\n\+ \#include <stdbool.h>\n\+ \#include <stdint.h>\n\+ \#include \"sys/queue.h\"\n\+ \#include \"HsFFI.h\"\n\+ \\n\+ \struct sptr;\n\+ \struct s_arena;\n\+ \struct s_cache;\n\+ \typedef void* *gc_t;\n\+ \typedef void* heap_t;  // a pointer into the GCed heap.\n\+ \\n\+ \#if defined(_JHC_JGC_BLOCK_SHIFT) && defined(_JHC_JGC_MEGABLOCK_SHIFT)\n\+ \#if (_JHC_JGC_BLOCK_SHIFT) >= (_JHC_JGC_MEGABLOCK_SHIFT)\n\+ \#error \"_JHC_JGC_MEGABLOCK_SHIFT should be larger than _JHC_JGC_BLOCK_SHIFT.\"\n\+ \#endif\n\+ \#elif defined(_JHC_JGC_BLOCK_SHIFT) || defined(_JHC_JGC_MEGABLOCK_SHIFT)\n\+ \#error \"Should define both _JHC_JGC_BLOCK_SHIFT and _JHC_JGC_MEGABLOCK_SHIFT.\"\n\+ \#else\n\+ \#define _JHC_JGC_BLOCK_SHIFT     12\n\+ \#define _JHC_JGC_MEGABLOCK_SHIFT 20\n\+ \#endif /* defined(_JHC_JGC_BLOCK_SHIFT) && defined(_JHC_JGC_MEGABLOCK_SHIFT) */\n\+ \\n\+ \#define BLOCK_SIZE     (1UL << (_JHC_JGC_BLOCK_SHIFT))\n\+ \#define MEGABLOCK_SIZE (1UL << (_JHC_JGC_MEGABLOCK_SHIFT))\n\+ \#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~(BLOCK_SIZE - 1)))\n\+ \#define TO_BLOCKS(x) (((x) + sizeof(uintptr_t) - 1)/sizeof(uintptr_t))\n\+ \\n\+ \extern struct s_arena *arena;\n\+ \extern gc_t saved_gc;\n\+ \\n\+ \void print_cache(struct s_cache *sc);\n\+ \struct s_cache *new_cache(struct s_arena *arena, unsigned short size,\n\+ \                          unsigned short num_ptrs);\n\+ \struct s_arena *new_arena(void);\n\+ \struct s_cache *find_cache(struct s_cache **rsc, struct s_arena *arena,\n\+ \                           unsigned short size, unsigned short num_ptrs);\n\+ \void gc_add_root(gc_t gc, void * root);\n\+ \void A_STD gc_perform_gc(gc_t gc);\n\+ \uint32_t get_heap_flags(void* sp);\n\+ \\n\+ \heap_t s_alloc(gc_t gc, struct s_cache *sc) A_STD;\n\+ \heap_t (gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs) A_STD;\n\+ \heap_t gc_array_alloc(gc_t gc, unsigned count) A_STD;\n\+ \heap_t gc_array_alloc_atomic(gc_t gc, unsigned count, unsigned slab_flags) A_STD;\n\+ \/* foreignptr, saved_gc must be set properly. */\n\+ \heap_t gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) A_STD;\n\+ \heap_t gc_new_foreignptr(HsPtr ptr) A_STD;\n\+ \bool gc_add_foreignptr_finalizer(struct sptr* fp, HsFunPtr finalizer) A_STD;\n\+ \\n\+ \#define gc_frame0(gc,n,...) void *ptrs[n] = { __VA_ARGS__ }; \\\n\+ \        for(int i = 0; i < n; i++) gc[i] = (sptr_t)ptrs[i]; \\\n\+ \        gc_t sgc = gc;  gc_t gc = sgc + n;\n\+ \#define gc_frame1(gc,p1) gc[0] = (sptr_t)p1; gc_t sgc = gc;  gc_t gc = sgc + 1;\n\+ \#define gc_frame2(gc,p1,p2) gc[0] = (sptr_t)p1; gc[1] = (sptr_t)p2; \\\n\+ \                                    gc_t sgc = gc;  gc_t gc = sgc + 2;\n\+ \\n\+ \struct StablePtr {\n\+ \    LIST_ENTRY(StablePtr) link;\n\+ \    struct sptr* contents;\n\+ \};\n\+ \\n\+ \extern LIST_HEAD(StablePtr_list, StablePtr) root_StablePtrs;\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/profile.c+{-# NOINLINE profile_c #-}+profile_c :: ByteString+profile_c = unsafePerformIO $ unsafePackAddress "\+ \// profiling and debugging code.\n\+ \\n\+ \#if defined(__WIN32__)\n\+ \#define HAVE_TIMES 0\n\+ \#else\n\+ \#define HAVE_TIMES 1\n\+ \#endif\n\+ \\n\+ \#include <stdio.h>\n\+ \#include <stdlib.h>\n\+ \#if HAVE_TIMES\n\+ \#include <sys/times.h>\n\+ \#include <time.h>\n\+ \#endif\n\+ \#include <unistd.h>\n\+ \\n\+ \#include \"jhc_rts_header.h\"\n\+ \\n\+ \void A_UNUSED\n\+ \profile_print_header(FILE *file, char *value_unit)\n\+ \{\n\+ \        fprintf(file, \"JOB \\\"%s\", jhc_progname);\n\+ \        for(int i = 0; i < jhc_argc; i++)\n\+ \                fprintf(file, \" %s\", jhc_argv[i]);\n\+ \        fprintf(file, \"\\\"\\n\");\n\+ \        fprintf(file, \"DATE \\\"%s\\\"\\n\", ctime(NULL));\n\+ \        fprintf(file, \"SAMPLE_UNIT \\\"seconds\\\"\\n\");\n\+ \        fprintf(file, \"VALUE_UNIT \\\"%s\\\"\\n\", value_unit ? value_unit : \"bytes\");\n\+ \}\n\+ \\n\+ \#if HAVE_TIMES\n\+ \struct profile_stack {\n\+ \    struct tms tm_total;\n\+ \    struct tms tm_pushed;\n\+ \};\n\+ \\n\+ \struct profile_stack gc_alloc_time;\n\+ \struct profile_stack gc_gc_time;\n\+ \\n\+ \void\n\+ \jhc_profile_push(struct profile_stack *ps)\n\+ \{\n\+ \        times(&ps->tm_pushed);\n\+ \}\n\+ \\n\+ \void\n\+ \jhc_profile_pop(struct profile_stack *ps)\n\+ \{\n\+ \    struct tms tm;\n\+ \    times(&tm);\n\+ \    ps->tm_total.tms_utime += tm.tms_utime - ps->tm_pushed.tms_utime;\n\+ \    ps->tm_total.tms_stime += tm.tms_stime - ps->tm_pushed.tms_stime;\n\+ \}\n\+ \\n\+ \void print_times(struct tms *tm) {\n\+ \#if  !defined(__WIN32__) && !defined(__ARM_EABI__)\n\+ \    float cpt = (float)sysconf(_SC_CLK_TCK);\n\+ \    fprintf(stderr, \"User Time:   %.2fs\\n\", (float)tm->tms_utime/cpt);\n\+ \    fprintf(stderr, \"System Time: %.2fs\\n\", (float)tm->tms_stime/cpt);\n\+ \    fprintf(stderr, \"Total Time:  %.2fs\\n\", (float)(tm->tms_stime + tm->tms_utime)/cpt);\n\+ \#endif\n\+ \    return;\n\+ \}\n\+ \#else\n\+ \\n\+ \struct profile_stack;\n\+ \void jhc_profile_push(struct profile_stack *ps) {}\n\+ \void jhc_profile_pop(struct profile_stack *ps) {}\n\+ \\n\+ \#endif\n\+ \\n\+ \void A_COLD\n\+ \jhc_print_profile(void) {\n\+ \        if(!(_JHC_PROFILE || getenv(\"AJHC_RTS_PROFILE\"))) return;\n\+ \        fprintf(stderr, \"\\n-----------------\\n\");\n\+ \        fprintf(stderr, \"Profiling: %s\\n\", jhc_progname);\n\+ \        fprintf(stderr, \"Command: %s\\n\", jhc_command);\n\+ \        fprintf(stderr, \"Complie: %s\\n\", jhc_c_compile);\n\+ \        fprintf(stderr, \"Version: %s\\n\\n\", jhc_version);\n\+ \#if HAVE_TIMES\n\+ \        struct tms tm;\n\+ \        times(&tm);\n\+ \        print_times(&tm);\n\+ \#endif\n\+ \#if _JHC_PROFILE\n\+ \        print_times(&gc_gc_time.tm_total);\n\+ \        print_times(&gc_alloc_time.tm_total);\n\+ \#endif\n\+ \        fprintf(stderr, \"-----------------\\n\");\n\+ \}\n\+ \\n\+ \#if _JHC_PROFILE && _JHC_GC != _JHC_GC_JGC\n\+ \\n\+ \#define BUCKETS 7\n\+ \static unsigned alloced[BUCKETS];\n\+ \static unsigned alloced_atomic[BUCKETS];\n\+ \\n\+ \static void\n\+ \alloc_count(int n,int atomic)\n\+ \{\n\+ \        n = n ? ((n - 1)/sizeof(void *)) + 1 : 0;\n\+ \        n = n > BUCKETS - 1 ? BUCKETS - 1 : n;\n\+ \        (atomic ? alloced_atomic : alloced)[n]++;\n\+ \}\n\+ \\n\+ \static void\n\+ \print_alloc_size_stats(void) {\n\+ \        char fmt[] = \"%10s %10s %10s %10s %10s\\n\";\n\+ \        char fmt2[] = \"%10u %10u %10u %10u %10u\\n\";\n\+ \        fprintf(stderr,fmt,\"Size\",\"Normal\",\"Atomic\",\"Total\",\"Accum\");\n\+ \        fprintf(stderr,fmt,\"----\",\"------\",\"------\",\"-----\",\"-----\");\n\+ \        unsigned accum = 0;\n\+ \        for(int i = 0; i < BUCKETS; i++) {\n\+ \                accum += alloced[i] + alloced_atomic[i];\n\+ \                fprintf(stderr,fmt2,i,alloced[i],alloced_atomic[i],alloced_atomic[i] + alloced[i], accum);\n\+ \        }\n\+ \}\n\+ \#endif\n\+ \\n\+ \#if JHC_MEM_ANNOTATE && _JHC_GC == _JHC_GC_JGC\n\+ \#include <Judy.h>\n\+ \\n\+ \static Pvoid_t mem_annotate = NULL;\n\+ \\n\+ \#define XSTR(x) #x\n\+ \#define STR(x) XSTR(x)\n\+ \#define gc_alloc(gc,sc,c,nptrs) \\\n\+ \    gc_alloc_annot(gc,sc,c,nptrs,(__FILE__ \":\" STR(__LINE__)))\n\+ \\n\+ \A_UNUSED static void *\n\+ \gc_alloc_annot(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs, char *str)\n\+ \{\n\+ \        void *ret = (gc_alloc)(gc,sc,count,nptrs);\n\+ \        PWord_t pval;\n\+ \        JLI(pval,mem_annotate,(Word_t)ret);\n\+ \        *pval = (Word_t)str;\n\+ \        return ret;\n\+ \}\n\+ \\n\+ \char *\n\+ \gc_lookup(void *ptr)\n\+ \{\n\+ \        PWord_t pval;\n\+ \        JLG(pval,mem_annotate,(Word_t)ptr & ~(Word_t)3);\n\+ \        return pval ? (char *)*pval : \"(none)\";\n\+ \}\n\+ \\n\+ \#endif\n\+ \\n\+ \#if _JHC_DEBUG  && _JHC_GC == _JHC_GC_JGC\n\+ \\n\+ \// these ensure the type synonyms are available to the debugger\n\+ \uintptr_t _dummy1;\n\+ \node_t *_dummy2;\n\+ \dnode_t *_dummy3;\n\+ \sptr_t *_dummy4;\n\+ \fptr_t *_dummy5;\n\+ \wptr_t *_dummy6;\n\+ \\n\+ \bool A_UNUSED\n\+ \jhc_valid_whnf(wptr_t s)\n\+ \{\n\+ \        return ((GET_PTYPE(s) == P_VALUE) || ((GET_PTYPE(s) == P_WHNF) && jhc_malloc_sanity(s,P_WHNF)));\n\+ \}\n\+ \\n\+ \bool A_UNUSED\n\+ \jhc_valid_lazy(sptr_t s)\n\+ \{\n\+ \        if(jhc_valid_whnf((wptr_t)s))\n\+ \                return true;\n\+ \        assert(GET_PTYPE(s) == P_LAZY);\n\+ \        node_t *ds = (node_t *)FROM_SPTR(s);\n\+ \        assert(jhc_malloc_sanity(ds,P_LAZY));\n\+ \        if(IS_LAZY(ds->head)) {\n\+ \                if(ds->head == BLACK_HOLE) return true;\n\+ \                assert(GET_PTYPE(ds->head) == P_FUNC);\n\+ \                return true;\n\+ \        } else\n\+ \                return jhc_valid_whnf((wptr_t)ds->head);\n\+ \}\n\+ \\n\+ \#endif\n\+ \\n\+ \#if _JHC_DEBUG\n\+ \wptr_t A_STD\n\+ \promote(sptr_t s)\n\+ \{\n\+ \        assert(!IS_LAZY(s));\n\+ \        assert(jhc_valid_whnf((wptr_t)s));\n\+ \        return (wptr_t)s;\n\+ \}\n\+ \\n\+ \sptr_t A_STD\n\+ \demote(wptr_t s)\n\+ \{\n\+ \        assert(!IS_LAZY(s));\n\+ \        assert(jhc_valid_whnf(s));\n\+ \        return (sptr_t)s;\n\+ \}\n\+ \\n\+ \void A_STD\n\+ \update(void * thunk, wptr_t new)\n\+ \{\n\+ \        assert(GETHEAD(thunk) == BLACK_HOLE);\n\+ \        assert(!IS_LAZY(new));\n\+ \        GETHEAD(thunk) = (fptr_t)new;\n\+ \}\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/profile.h+{-# NOINLINE profile_h #-}+profile_h :: ByteString+profile_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef RTS_PROFILE_H\n\+ \#define RTS_PROFILE_H\n\+ \\n\+ \#include <stdio.h>\n\+ \#include \"rts/cdefs.h\"\n\+ \\n\+ \#ifndef JHC_VALGRIND\n\+ \#define JHC_VALGRIND 0\n\+ \#endif\n\+ \\n\+ \#ifndef JHC_MEM_ANNOTATE\n\+ \#define JHC_MEM_ANNOTATE 0\n\+ \#endif\n\+ \\n\+ \#ifndef _JHC_PROFILE\n\+ \#define _JHC_PROFILE 0\n\+ \#endif\n\+ \\n\+ \#if JHC_VALGRIND\n\+ \#include <valgrind/valgrind.h>\n\+ \#include <valgrind/memcheck.h>\n\+ \#else\n\+ \#define VALGRIND_MAKE_MEM_UNDEFINED(x,y) \\\n\+ \    do { } while (0)\n\+ \#define VALGRIND_MAKE_MEM_DEFINED(x,y) \\\n\+ \    do { } while (0)\n\+ \#define VALGRIND_MAKE_MEM_NOACCESS(x,y) \\\n\+ \    do { } while (0)\n\+ \#define VALGRIND_PRINTF(...) \\\n\+ \    do { } while (0)\n\+ \#endif\n\+ \\n\+ \void A_UNUSED profile_print_header(FILE *file, char *value_unit);\n\+ \void A_COLD jhc_print_profile(void);\n\+ \\n\+ \#if _JHC_PROFILE\n\+ \struct profile_stack;\n\+ \extern struct profile_stack gc_alloc_time;\n\+ \extern struct profile_stack gc_gc_time;\n\+ \void jhc_profile_push(struct profile_stack *ps);\n\+ \void jhc_profile_pop(struct profile_stack *ps);\n\+ \#define profile_push(x) jhc_profile_push(x)\n\+ \#define profile_pop(x)  jhc_profile_pop(x)\n\+ \#else\n\+ \#define profile_push(x)          do { } while(0)\n\+ \#define profile_pop(x)           do { } while(0)\n\+ \#define alloc_count(x,y)         do { } while(0)\n\+ \#define print_alloc_size_stats() do { } while(0)\n\+ \#endif\n\+ \\n\+ \#if JHC_STATUS > 1\n\+ \#define debugf(...) fprintf(stderr,__VA_ARGS__)\n\+ \#else\n\+ \#define debugf(...) do { } while (0)\n\+ \#endif\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/cdefs.h+{-# NOINLINE cdefs_h #-}+cdefs_h :: ByteString+cdefs_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef RTS_CDEFS_H\n\+ \#define RTS_CDEFS_H\n\+ \\n\+ \// GNU attributes\n\+ \#if !defined(__predict_true)\n\+ \#ifdef __GNUC__\n\+ \#  define __predict_true(exp)     __builtin_expect(!!(exp), 1)\n\+ \#  define __predict_false(exp)    __builtin_expect(!!(exp), 0)\n\+ \#else\n\+ \#  define __predict_true(exp)     (exp)\n\+ \#  define __predict_false(exp)    (exp)\n\+ \#endif\n\+ \#endif\n\+ \\n\+ \#ifdef __GNUC__\n\+ \#define A_ALIGNED  __attribute__ ((aligned))\n\+ \#define A_CONST    __attribute__ ((const))\n\+ \#define A_MALLOC   __attribute__ ((malloc))\n\+ \#define A_MAYALIAS __attribute__ ((__may_alias__))\n\+ \#define A_NORETURN __attribute__ ((noreturn))\n\+ \#define A_PURE     __attribute__ ((pure))\n\+ \#define A_UNUSED   __attribute__ ((unused))\n\+ \#ifdef __i386__\n\+ \#define A_REGPARM __attribute__ ((fastcall))\n\+ \#else\n\+ \#define A_REGPARM\n\+ \#endif\n\+ \#define A_STD    A_REGPARM\n\+ \\n\+ \#else\n\+ \#define A_ALIGNED\n\+ \#define A_CONST\n\+ \#define A_MALLOC\n\+ \#define A_MAYALIAS\n\+ \#define A_NORETURN\n\+ \#define A_PURE\n\+ \#define A_UNUSED\n\+ \#define A_STD\n\+ \#endif\n\+ \\n\+ \// these should be enabled with newer versions of gcc\n\+ \#define A_HOT\n\+ \#define A_COLD\n\+ \#define A_FALIGNED\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/rts_support.c+{-# NOINLINE rts_support_c #-}+rts_support_c :: ByteString+rts_support_c = unsafePerformIO $ unsafePackAddress "\+ \#include <stdio.h>\n\+ \#include <stdlib.h>\n\+ \#include <locale.h>\n\+ \\n\+ \#include \"HsFFI.h\"\n\+ \#include \"rts/rts_support.h\"\n\+ \#include \"rts/profile.h\"\n\+ \#include \"rts/gc.h\"\n\+ \\n\+ \jmp_buf jhc_uncaught;\n\+ \int jhc_argc;\n\+ \char **jhc_argv;\n\+ \char *jhc_progname;\n\+ \\n\+ \#ifdef __WIN32__\n\+ \A_UNUSED char *jhc_options_os =  \"mingw32\";\n\+ \A_UNUSED char *jhc_options_arch = \"i386\";\n\+ \#elif defined(__ARM_EABI__)\n\+ \A_UNUSED char *jhc_options_os =  \"nds\";\n\+ \A_UNUSED char *jhc_options_arch = \"ARM\";\n\+ \#else\n\+ \A_UNUSED char *jhc_options_os = \"(unknown os)\";\n\+ \A_UNUSED char *jhc_options_arch = \"(unknown arch)\";\n\+ \#endif\n\+ \\n\+ \void\n\+ \hs_set_argv(int argc, char *argv[])\n\+ \{\n\+ \        jhc_argc = argc - 1;\n\+ \        jhc_argv = argv + 1;\n\+ \        jhc_progname = argv[0];\n\+ \}\n\+ \\n\+ \void A_NORETURN A_UNUSED A_COLD\n\+ \jhc_exit(int n) {\n\+ \        fflush(stdout);\n\+ \        jhc_print_profile();\n\+ \        exit(n);\n\+ \}\n\+ \\n\+ \void  A_NORETURN A_UNUSED  A_COLD\n\+ \jhc_error(char *s) {\n\+ \        fflush(stdout);\n\+ \        fputs(s,stderr);\n\+ \        fputs(\"\\n\",stderr);\n\+ \        jhc_exit(1);\n\+ \}\n\+ \\n\+ \void  A_NORETURN A_UNUSED  A_COLD\n\+ \jhc_case_fell_off(int n) {\n\+ \        fflush(stdout);\n\+ \        fprintf(stderr, \"\\n%s:%i: case fell off\\n\", __FILE__, n);\n\+ \        abort();\n\+ \}\n\+ \\n\+ \void jhc_hs_init(void);\n\+ \\n\+ \static int hs_init_count;\n\+ \void\n\+ \hs_init(int *argc, char **argv[])\n\+ \{\n\+ \\n\+ \        if(!hs_init_count++) {\n\+ \                jhc_alloc_init();\n\+ \                jhc_hs_init();\n\+ \                hs_set_argv(*argc,*argv);\n\+ \#if JHC_isPosix\n\+ \                struct utsname jhc_utsname;\n\+ \                if(!uname(&jhc_utsname)) {\n\+ \                        jhc_options_arch = jhc_utsname.machine;\n\+ \                        jhc_options_os   = jhc_utsname.sysname;\n\+ \                }\n\+ \#endif\n\+ \                setlocale(LC_ALL,\"\");\n\+ \        }\n\+ \}\n\+ \\n\+ \void\n\+ \hs_exit(void)\n\+ \{\n\+ \        if(!hs_init_count) {\n\+ \                fprintf(stderr, \"hs_exit() called before hs_init()\\n\");\n\+ \                abort();\n\+ \        }\n\+ \        if(!--hs_init_count) {\n\+ \                jhc_alloc_fini();\n\+ \                jhc_exit(0);\n\+ \        }\n\+ \}\n\+ \"#++-- | Generated from rts\/rts\/rts_support.h+{-# NOINLINE rts_support_h #-}+rts_support_h :: ByteString+rts_support_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef RTS_SUPPORT_H\n\+ \#define RTS_SUPPORT_H\n\+ \\n\+ \#include <setjmp.h>\n\+ \#include \"rts/cdefs.h\"\n\+ \\n\+ \extern jmp_buf jhc_uncaught;\n\+ \A_UNUSED extern char *jhc_options_os;\n\+ \A_UNUSED extern char *jhc_options_arch;\n\+ \extern int jhc_argc;\n\+ \extern char **jhc_argv;\n\+ \extern char *jhc_progname;\n\+ \\n\+ \extern char jhc_c_compile[];\n\+ \extern char jhc_command[];\n\+ \extern char jhc_version[];\n\+ \\n\+ \void A_NORETURN A_UNUSED A_COLD jhc_exit(int n);\n\+ \void A_NORETURN A_UNUSED A_COLD jhc_error(char *s);\n\+ \void A_NORETURN A_UNUSED A_COLD jhc_case_fell_off(int n);\n\+ \\n\+ \#define jhc_setjmp(jb) setjmp(*(jb))\n\+ \#define jhc_longjmp(jb) longjmp(*(jb),1)\n\+ \\n\+ \#define prim_umaxbound(t) ((t)~((t)0))\n\+ \#define prim_maxbound(t) ((t)(~((t)1 << (sizeof(t)*CHAR_BIT - 1))))\n\+ \#define prim_minbound(t) ((t)(((t)1 << (sizeof(t)*CHAR_BIT - 1))))\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/gc.h+{-# NOINLINE gc_h #-}+gc_h :: ByteString+gc_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef JHC_GC_H\n\+ \#define JHC_GC_H\n\+ \\n\+ \#define _JHC_GC_NONE   0\n\+ \#define _JHC_GC_JGC    1\n\+ \#define _JHC_GC_BOEHM  2\n\+ \#define _JHC_GC_REGION 3\n\+ \\n\+ \#ifndef _JHC_GC\n\+ \#define _JHC_GC _JHC_GC_NONE\n\+ \#endif\n\+ \\n\+ \void jhc_alloc_init(void);\n\+ \void jhc_alloc_fini(void);\n\+ \\n\+ \#include \"rts/gc_none.h\"\n\+ \#include \"rts/gc_jgc.h\"\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/gc_none.c+{-# NOINLINE gc_none_c #-}+gc_none_c :: ByteString+gc_none_c = unsafePerformIO $ unsafePackAddress "\+ \#include <stdlib.h>\n\+ \#include <stdio.h>\n\+ \#include \"rts/gc.h\"\n\+ \#include \"rts/profile.h\"\n\+ \\n\+ \#if _JHC_GC == _JHC_GC_BOEHM\n\+ \\n\+ \void hs_perform_gc(void) {\n\+ \        GC_gcollect();\n\+ \}\n\+ \\n\+ \void jhc_alloc_init(void) { GC_INIT(); }\n\+ \void jhc_alloc_fini(void) { }\n\+ \\n\+ \#elif _JHC_GC == _JHC_GC_NONE\n\+ \\n\+ \// memory allocated in 1MB chunks.\n\+ \#define JHC_MEM_CHUNK_SIZE (1 << 20)\n\+ \\n\+ \static char initial_chunk[JHC_MEM_CHUNK_SIZE];\n\+ \\n\+ \static void *jhc_current_chunk = initial_chunk;\n\+ \static unsigned mem_chunks,mem_offset;\n\+ \\n\+ \void jhc_alloc_init(void) {}\n\+ \\n\+ \void\n\+ \jhc_alloc_fini(void) {\n\+ \        if(_JHC_PROFILE) {\n\+ \                fprintf(stderr, \"Memory Allocated: %u bytes\\n\", (JHC_MEM_CHUNK_SIZE*(mem_chunks)) + mem_offset);\n\+ \                print_alloc_size_stats();\n\+ \        }\n\+ \}\n\+ \\n\+ \static void\n\+ \jhc_malloc_grow(void) {\n\+ \        void *c = malloc(JHC_MEM_CHUNK_SIZE);\n\+ \        if(!c) {\n\+ \                fputs(\"Out of memory!\\n\",stderr);\n\+ \                abort();\n\+ \        }\n\+ \        mem_chunks++;\n\+ \        jhc_current_chunk = c;\n\+ \        mem_offset = 0;\n\+ \}\n\+ \\n\+ \#define M_ALIGN(a,n) ((n) - 1 + ((a) - ((n) - 1) % (a)))\n\+ \\n\+ \static inline void * A_MALLOC\n\+ \jhc_malloc_basic(size_t n) {\n\+ \        n = M_ALIGN(sizeof(void *),n);\n\+ \        if (n > (JHC_MEM_CHUNK_SIZE - mem_offset))\n\+ \                jhc_malloc_grow();\n\+ \        void *ret = jhc_current_chunk + mem_offset;\n\+ \        mem_offset += n;\n\+ \        return ret;\n\+ \}\n\+ \\n\+ \#if _JHC_DEBUG\n\+ \\n\+ \void * A_MALLOC\n\+ \jhc_malloc_debug(size_t n,int line,int atomic) {\n\+ \        alloc_count(n,atomic);\n\+ \        void *ret = jhc_malloc_basic(n + sizeof(uintptr_t));\n\+ \        *((uintptr_t *)ret) = line;\n\+ \        return ret + sizeof(uintptr_t);\n\+ \}\n\+ \\n\+ \#else\n\+ \\n\+ \void * A_MALLOC\n\+ \jhc_malloc(size_t n) {\n\+ \        alloc_count(n,0);\n\+ \        return jhc_malloc_basic(n);\n\+ \}\n\+ \\n\+ \#undef jhc_malloc_atomic\n\+ \void * A_MALLOC\n\+ \jhc_malloc_atomic(size_t n) {\n\+ \        alloc_count(n,1);\n\+ \        return jhc_malloc_basic(n);\n\+ \}\n\+ \\n\+ \#endif\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/gc_none.h+{-# NOINLINE gc_none_h #-}+gc_none_h :: ByteString+gc_none_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef GC_NONE_H\n\+ \#define GC_NONE_H\n\+ \\n\+ \#include <stddef.h>\n\+ \#include \"rts/cdefs.h\"\n\+ \\n\+ \#define jhc_malloc_sanity(p,t) (1)\n\+ \\n\+ \#if _JHC_GC == _JHC_GC_BOEHM\n\+ \\n\+ \#include \"rts/profile.h\"\n\+ \\n\+ \#include <gc/gc.h>\n\+ \\n\+ \#define jhc_malloc GC_malloc\n\+ \#define jhc_malloc_atomic GC_malloc_atomic\n\+ \\n\+ \#elif _JHC_GC == _JHC_GC_NONE\n\+ \\n\+ \#if _JHC_DEBUG\n\+ \void * A_MALLOC jhc_malloc_debug(size_t n,int line,int atomic);\n\+ \#define jhc_malloc(n) jhc_malloc_debug(n,__LINE__,0)\n\+ \#define jhc_malloc_atomic(n) jhc_malloc_debug(n,__LINE__,1)\n\+ \#else\n\+ \void * A_MALLOC jhc_malloc(size_t n);\n\+ \void * A_MALLOC jhc_malloc_atomic(size_t n);\n\+ \#endif\n\+ \\n\+ \#endif\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/jhc_rts.c+{-# NOINLINE jhc_rts_c #-}+jhc_rts_c :: ByteString+jhc_rts_c = unsafePerformIO $ unsafePackAddress "\+ \/*@Internals\n\+ \\n\+ \# The Run Time System\n\+ \\n\+ \Ajhc is very minimalist in that it does not have a precompiled run time system,\n\+ \but rather generates what is needed as part of the compilation process.\n\+ \However, back ends do have specific run-time representations of data, which can\n\+ \be affected by things like the choice of garbage collector. The following\n\+ \describes the general layout for the C based back-ends, but compiler options\n\+ \such as garbage collection method or whether we do full program analysis, will\n\+ \affect which features are used and whether certain optimized layouts are\n\+ \possible.\n\+ \\n\+ \Unboxed values directly translate to values in the target language, an unboxed\n\+ \Int will translate directly into an 'int' as an argument and an unboxed pointer\n\+ \will be a raw pointer. Unboxed values have no special interpretation and are\n\+ \_not_ followed by the garbage collector. If the target language does not\n\+ \support a feature such as multiple return values, it will have to be simulated.\n\+ \It would not be wrong to think of Grin code that only deals with unboxed values\n\+ \to be isomorphic to C-- or C augmented with multiple return values.\n\+ \\n\+ \Boxed values have a standard representation and can be followed. Unlike some\n\+ \other implementation, being boxed does not imply the object is located on the\n\+ \heap. It may be on the stack, heap, or even embedded within the smart pointer\n\+ \itself. Being boxed only means that the object may be represented by a smart\n\+ \pointer, which may or may not actually be a pointer in the traditional sense.\n\+ \\n\+ \A boxed value in Ajhc is represented by a 'smart pointer' of c type sptr_t. a\n\+ \smart pointer is the size of a native pointer, but can take on different roles\n\+ \depending on a pair of tag bits, called the ptype.\n\+ \\n\+ \smart pointers take on a general form as follows:\n\+ \\n\+ \    -------------------------\n\+ \    |    payload        | GL|\n\+ \    -------------------------\n\+ \\n\+ \      G - if set, then the garbage collector should not treat value as a pointer to be followed\n\+ \      L - lazy, this bit being set means the value is potentially not in WHNF\n\+ \\n\+ \A sptr_t on its own in the wild can only take on one of the following forms:\n\+ \\n\+ \    -------------------------\n\+ \    |    whnf raw value | 10|\n\+ \    -------------------------\n\+ \\n\+ \    -------------------------\n\+ \    |    whnf location  | 00|\n\+ \    -------------------------\n\+ \\n\+ \WHNF stands for 'Weak Head Normal Form' and means that the value is not a\n\+ \suspended function and hence not a pointer to a thunk. It may be directly\n\+ \examined and need not be evaluated. wptr_t is an alias for sptr_t that is\n\+ \guarenteed to be of one of the above forms. It is used to improve safety for\n\+ \when we can statically know that a value is WHNF and hence we can skip the\n\+ \expensive 'eval'.\n\+ \\n\+ \The difference between the raw value and the whnf location is that the first\n\+ \contains uninterpreted bits, while the second is a pointer to a location on the\n\+ \heap or stack and hence the garbage collector should follow it. The format of\n\+ \the memory pointed to by the whnf location is unspecified and dependent on the\n\+ \actual type being represented.\n\+ \\n\+ \Partial (unsaturated) applications are normal WHNF values. Saturated\n\+ \applications which may be 'eval'ed and updated are called thunks and must not\n\+ \be pointed to by WHNF pointers. Their representation follows.\n\+ \\n\+ \    -------------------------\n\+ \    |   lazy location   | 01|\n\+ \    -------------------------\n\+ \\n\+ \A lazy location points to either a thunk, or a redirection to a WHNF value. A\n\+ \lazy location is always a pointer to an allocated block of memory which always\n\+ \begins with a restricted smart pointer. This restricted smart pointer is represented by\n\+ \the C type alias 'fptr_t'. fptr_t's only occur as the first entry in a lazy\n\+ \location, they never are passed around as objects in their own right.\n\+ \\n\+ \A fptr_t may be a whnf value or a code pointer. If a fptr_t is a whnf value (of one of\n\+ \the two forms given above) then it is called a redirection, the lazy location should be\n\+ \treated exactly as if it were the whnf given. This is used to redirect an evaluated\n\+ \thunk to its computed value.\n\+ \\n\+ \A fptr_t may also be a 'code pointer' in which case the lazy location is called\n\+ \a thunk. A code pointer is a pointer to executable machine code that evaluates\n\+ \a closure and returns a wptr_t, the returned wptr_t is then generally written\n\+ \over the code pointer, turning the thunk into a redirection. It is the\n\+ \responsibility of the code pointed to to perform this redirection.\n\+ \\n\+ \    -------------------------\n\+ \    |    code pointer   | 11|\n\+ \    -------------------------\n\+ \    |     data ...          |\n\+ \\n\+ \When debugging, the special code pointer BLACK_HOLE is also sometimes stored in\n\+ \a fptr_t to detect certain run-time errors.\n\+ \\n\+ \Note that unlike other implementations, a fptr_t may _not_ be another lazy\n\+ \location. you can not have chained redirections, a redirection is always a\n\+ \redirection to a whnf value.\n\+ \\n\+ \    sptr_t - a tagged smart pointer, may contain a whnf value or a lazy location.\n\+ \    wptr_t - a tagged smart pointer that contains a whnf value (either raw or a location)\n\+ \    fptr_t - a tagged smart pointer, may contain a whnf value indicating a redirection, or a code pointer indicating a thunk.\n\+ \\n\+ \*/\n\+ \\n\+ \#include \"jhc_rts_header.h\"\n\+ \\n\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \typedef wptr_t (*eval_fn)(gc_t gc,node_t *node) A_STD;\n\+ \#else\n\+ \typedef wptr_t (*eval_fn)(node_t *node) A_STD;\n\+ \#endif\n\+ \\n\+ \// like eval but you know the target is in WHNF or is a already evaluated indirection\n\+ \static inline wptr_t A_STD A_UNUSED  A_HOT\n\+ \follow(sptr_t s)\n\+ \{\n\+ \        assert(jhc_valid_lazy(s));\n\+ \        if(IS_LAZY(s)) {\n\+ \                sptr_t h = (sptr_t)(GETHEAD(FROM_SPTR(s)));\n\+ \                assert(!IS_LAZY(h));\n\+ \                return (wptr_t)h;\n\+ \        }\n\+ \        return (wptr_t)s;\n\+ \}\n\+ \\n\+ \wptr_t A_STD A_UNUSED  A_HOT\n\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \eval(gc_t gc,sptr_t s)\n\+ \#else\n\+ \eval(sptr_t s)\n\+ \#endif\n\+ \{\n\+ \        assert(jhc_valid_lazy(s));\n\+ \        if(IS_LAZY(s)) {\n\+ \                assert(GET_PTYPE(s) == P_LAZY);\n\+ \                void *ds = FROM_SPTR(s);\n\+ \                sptr_t h = (sptr_t)(GETHEAD(ds));\n\+ \                assert((fptr_t)h != BLACK_HOLE);\n\+ \                if(IS_LAZY(h)) {\n\+ \                        eval_fn fn = (eval_fn)FROM_SPTR(h);\n\+ \                        assert(GET_PTYPE(h) == P_FUNC);\n\+ \#if _JHC_DEBUG\n\+ \                        GETHEAD(ds) = BLACK_HOLE;\n\+ \#endif\n\+ \                        fn = (eval_fn)SET_THUMB_BIT(fn);\n\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \                        wptr_t r = (*fn)(gc,NODEP(ds));\n\+ \#else\n\+ \                        wptr_t r = (*fn)(NODEP(ds));\n\+ \#endif\n\+ \#if _JHC_DEBUG\n\+ \                        assert(GETHEAD(ds) != BLACK_HOLE);\n\+ \#endif\n\+ \                        return r;\n\+ \                }\n\+ \                return (wptr_t)h;\n\+ \        }\n\+ \        assert(jhc_valid_whnf((wptr_t)s));\n\+ \        return (wptr_t)s;\n\+ \}\n\+ \\n\+ \#if _JHC_STANDALONE\n\+ \int\n\+ \main(int argc, char *argv[])\n\+ \{\n\+ \        hs_init(&argc,&argv);\n\+ \        if (jhc_setjmp(&jhc_uncaught))\n\+ \                jhc_error(\"Uncaught Exception\");\n\+ \        else\n\+ \                _amain();\n\+ \        hs_exit();\n\+ \        return 0;\n\+ \}\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/jhc_rts.h+{-# NOINLINE jhc_rts_h #-}+jhc_rts_h :: ByteString+jhc_rts_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef JHC_RTS_H\n\+ \#define JHC_RTS_H\n\+ \\n\+ \#include \"rts/profile.h\"\n\+ \#include \"rts/gc.h\"\n\+ \\n\+ \struct sptr;\n\+ \struct wptr;\n\+ \struct fptr;\n\+ \\n\+ \// we use dummy structs here so the compiler will catch any attempt\n\+ \// to use one type in anothers place\n\+ \typedef struct sptr * sptr_t;\n\+ \typedef struct sptr * wptr_t;\n\+ \typedef struct fptr * fptr_t;\n\+ \typedef uintptr_t     what_t;\n\+ \\n\+ \typedef struct node {\n\+ \        fptr_t head;\n\+ \        sptr_t rest[];\n\+ \} A_MAYALIAS node_t;\n\+ \\n\+ \typedef struct dnode {\n\+ \        what_t what;\n\+ \        sptr_t rest[];\n\+ \} A_MAYALIAS dnode_t;\n\+ \\n\+ \#define P_WHNF  0x0\n\+ \#define P_LAZY  0x1\n\+ \#define P_VALUE 0x2\n\+ \#define P_FUNC  0x3\n\+ \\n\+ \#define IS_LAZY(x)     (bool)(((uintptr_t)(x)) & 0x1)\n\+ \#define IS_PTR(x)      (bool)(!(((uintptr_t)(x)) & 0x2))\n\+ \\n\+ \#define FROM_SPTR(x)   (typeof (x))((uintptr_t)(x) & ~0x3)  // remove a ptype from a smart pointer\n\+ \#define GET_PTYPE(x)   ((uintptr_t)(x) & 0x3)               // return the ptype associated with a smart pointer\n\+ \#define TO_SPTR(t,x)   (typeof (x))((uintptr_t)(x) | (t))   // attach a ptype to a smart pointer\n\+ \#define TO_SPTR_C(t,x) (typeof (x))((uintptr_t)(x) + (t))   // attach a ptype to a smart pointer, suitable for use by constant initialializers\n\+ \\n\+ \#define GETHEAD(x)   (NODEP(x)->head)\n\+ \#define NODEP(x)     ((node_t *)(x))\n\+ \#define DNODEP(x)    ((dnode_t *)(x))\n\+ \\n\+ \#define MKLAZY(fn)    TO_SPTR(P_LAZY,(sptr_t)fn)\n\+ \#define MKLAZY_C(fn)  TO_SPTR_C(P_LAZY,(sptr_t)fn)\n\+ \#define TO_FPTR(fn)   TO_SPTR_C(P_FUNC,(fptr_t)fn)\n\+ \\n\+ \#define RAW_SET_F(n)   ((wptr_t)(((intptr_t)(n) << 2) | P_VALUE))\n\+ \#define RAW_SET_UF(n)  ((wptr_t)(((uintptr_t)(n) << 2) | P_VALUE))\n\+ \#define RAW_GET_F(n)   ((intptr_t)(n) >> 2)\n\+ \#define RAW_GET_UF(n)  ((uintptr_t)(n) >> 2)\n\+ \\n\+ \#define RAW_SET_16(w)  (wptr_t)(((uintptr_t)(w) << 16) | P_VALUE)\n\+ \#define RAW_GET_16(n)  ((intptr_t)(n) >> 16)\n\+ \#define RAW_GET_U16(n) ((uintptr_t)(n) >> 16)\n\+ \\n\+ \// demote is always safe, we must only promote when we know the argument is a WHNF\n\+ \#define PROMOTE(n)   ((wptr_t)(n))\n\+ \#define DEMOTE(n)    ((sptr_t)(n))\n\+ \\n\+ \#define FETCH_TAG(x)      RAW_GET_U16(IS_PTR(x) ? FETCH_MEM_TAG(x) : (what_t)(x))\n\+ \#define FETCH_RAW_TAG(x)  RAW_GET_U16(x)\n\+ \#define SET_RAW_TAG(x)    RAW_SET_16(x)\n\+ \#define FETCH_MEM_TAG(x)  (DNODEP(x)->what)\n\+ \#define SET_MEM_TAG(x,v)  (DNODEP(x)->what = (what_t)RAW_SET_16(v))\n\+ \\n\+ \#define BLACK_HOLE TO_FPTR(0xDEADBEE0)\n\+ \\n\+ \wptr_t A_STD\n\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \eval(gc_t gc,sptr_t s);\n\+ \#else\n\+ \eval(sptr_t s);\n\+ \#endif\n\+ \\n\+ \// both promote and demote evaluate to nothing when debugging is not enabled\n\+ \// otherwise, they check that their arguments are in the correct form.\n\+ \#if _JHC_DEBUG\n\+ \wptr_t A_STD promote(sptr_t s);\n\+ \sptr_t A_STD demote(wptr_t s);\n\+ \void   A_STD update(void *, wptr_t);\n\+ \#else\n\+ \#define promote(x) PROMOTE(x)\n\+ \#define demote(x) DEMOTE(x)\n\+ \inline static void update(void *t, wptr_t n) { GETHEAD(t) = (fptr_t)n; }\n\+ \#endif\n\+ \\n\+ \#if _JHC_DEBUG && _JHC_GC == _JHC_GC_JGC\n\+ \bool jhc_valid_whnf(wptr_t s);\n\+ \bool jhc_valid_lazy(sptr_t s);\n\+ \#else\n\+ \#define jhc_valid_whnf(x) true\n\+ \#define jhc_valid_lazy(x) true\n\+ \#endif\n\+ \\n\+ \#endif\n\+ \\n\+ \/*\n\+ \ * Detail:\n\+ \ * http://communities.mentor.com/community/cs/archives/arm-gnu/msg01904.html\n\+ \ */\n\+ \#ifdef _JHC_ARM_STAY_IN_THUMB_MODE\n\+ \#define SET_THUMB_BIT(fn)    TO_SPTR(0x1,(sptr_t)fn)\n\+ \#else\n\+ \#define SET_THUMB_BIT(fn)    (fn)\n\+ \#endif\n\+ \"#++-- | Generated from rts\/lib\/lib_cbits.c+{-# NOINLINE lib_cbits_c #-}+lib_cbits_c :: ByteString+lib_cbits_c = unsafePerformIO $ unsafePackAddress "\+ \/* this file contains C only needed to help support the\n\+ \ * standard libraries */\n\+ \\n\+ \#include <stdio.h>\n\+ \\n\+ \#include \"HsFFI.h\"\n\+ \#include \"rts/cdefs.h\"\n\+ \\n\+ \HsInt jhc_stdrnd[2] A_UNUSED = { 1 , 1 };\n\+ \HsInt jhc_data_unique A_UNUSED;\n\+ \\n\+ \HsBool A_UNUSED\n\+ \jhc_wait_for_input(FILE *f,HsInt timeout) {\n\+ \#if JHC_isPosix\n\+ \        fd_set fds;\n\+ \        FD_ZERO(&fds);\n\+ \        FD_SET(fileno(f),&fds);\n\+ \        struct timeval to = {  0, timeout * 1000 };\n\+ \        int retval = select(1,&fds,NULL,&fds,&to);\n\+ \        if(retval)\n\+ \                return HS_BOOL_TRUE;\n\+ \        else\n\+ \                return HS_BOOL_FALSE;\n\+ \#else\n\+ \        return HS_BOOL_FALSE;\n\+ \#endif\n\+ \}\n\+ \\n\+ \uint32_t\n\+ \jhc_hash32(uint32_t key)\n\+ \{\n\+ \  int c2=0x27d4eb2d; // a prime or an odd constant\n\+ \  key = (key ^ 61) ^ (key >> 16);\n\+ \  key = key + (key << 3);\n\+ \  key = key ^ (key >> 4);\n\+ \  key = key * c2;\n\+ \  key = key ^ (key >> 15);\n\+ \  return key;\n\+ \}\n\+ \\n\+ \uint64_t jhc_hash64(uint64_t key)\n\+ \{\n\+ \  key = (~key) + (key << 21); // key = (key << 21) - key - 1;\n\+ \  key = key ^ (key >> 24);\n\+ \  key = (key + (key << 3)) + (key << 8); // key * 265\n\+ \  key = key ^ (key >> 14);\n\+ \  key = (key + (key << 2)) + (key << 4); // key * 21\n\+ \  key = key ^ (key >> 28);\n\+ \  key = key + (key << 31);\n\+ \  return key;\n\+ \}\n\+ \\n\+ \uintptr_t\n\+ \jhc_hashptr(uintptr_t key)\n\+ \{\n\+ \    if (sizeof(uintptr_t) == sizeof(uint32_t)) {\n\+ \        return (uintptr_t)jhc_hash32((uint32_t)key);\n\+ \    } else {\n\+ \        return (uintptr_t)jhc_hash64((uint64_t)key);\n\+ \    }\n\+ \}\n\+ \"#++-- | Generated from rts\/jhc_rts_header.h+{-# NOINLINE jhc_rts_header_h #-}+jhc_rts_header_h :: ByteString+jhc_rts_header_h = unsafePerformIO $ unsafePackAddress "\+ \#include <assert.h>\n\+ \#include <errno.h>\n\+ \#include <float.h>\n\+ \#include <limits.h>\n\+ \#include <locale.h>\n\+ \#include <math.h>\n\+ \#include <stdio.h>\n\+ \#include <stdlib.h>\n\+ \#include <string.h>\n\+ \#include <time.h>\n\+ \#include <unistd.h>\n\+ \#include <wchar.h>\n\+ \#include <setjmp.h>\n\+ \#ifndef __WIN32__\n\+ \#ifdef __ARM_EABI__\n\+ \#include <malloc.h>\n\+ \#else\n\+ \#include <sys/select.h>\n\+ \#include <sys/utsname.h>\n\+ \#endif\n\+ \#include <sys/times.h>\n\+ \#include <sys/types.h>\n\+ \#include <sys/param.h>\n\+ \#else\n\+ \#include <malloc.h>\n\+ \#endif\n\+ \\n\+ \#include \"HsFFI.h\"\n\+ \#include \"sys/wsize.h\"\n\+ \#include \"rts/cdefs.h\"\n\+ \\n\+ \#ifndef _JHC_DEBUG\n\+ \#ifdef NDEBUG\n\+ \#define _JHC_DEBUG 0\n\+ \#else\n\+ \#define _JHC_DEBUG 1\n\+ \#endif\n\+ \#endif\n\+ \\n\+ \#ifndef _JHC_STANDALONE\n\+ \#define _JHC_STANDALONE 1\n\+ \#endif\n\+ \\n\+ \#ifndef JHC_STATUS\n\+ \#define JHC_STATUS 0\n\+ \#endif\n\+ \\n\+ \#ifdef __WIN32__\n\+ \#define JHC_isWindows   1\n\+ \#define JHC_isBigEndian 0\n\+ \#else\n\+ \#define JHC_isWindows 0\n\+ \#define JHC_isBigEndian (__BYTE_ORDER == __BIG_ENDIAN)\n\+ \#endif\n\+ \\n\+ \#define JHC_isPosix (!JHC_isWindows && !defined(__ARM_EABI__))\n\+ \\n\+ \// the program will provide the following\n\+ \void _amain(void);\n\+ \void jhc_hs_init(void);\n\+ \extern const void * const nh_stuff[];\n\+ \\n\+ \#include \"rts/profile.h\"\n\+ \#include \"rts/rts_support.h\"\n\+ \#include \"rts/gc.h\"\n\+ \#include \"rts/jhc_rts.h\"\n\+ \#include \"lib/lib_cbits.h\"\n\+ \"#++-- | Generated from rts\/lib\/lib_cbits.h+{-# NOINLINE lib_cbits_h #-}+lib_cbits_h :: ByteString+lib_cbits_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef LIB_CBITS_H\n\+ \#define LIB_CBITS_H\n\+ \\n\+ \#include \"HsFFI.h\"\n\+ \struct FILE;\n\+ \\n\+ \extern HsInt jhc_stdrnd[2];\n\+ \extern HsInt jhc_data_unique;\n\+ \HsBool jhc_wait_for_input(FILE *f,HsInt timeout);\n\+ \\n\+ \#ifdef __WIN32__\n\+ \#define getchar_unlocked() getchar()\n\+ \#define putchar_unlocked(x) putchar(x)\n\+ \#define getc_unlocked(x) getc(x)\n\+ \#define putc_unlocked(x,y) putc(x,y)\n\+ \#endif\n\+ \\n\+ \inline static int A_UNUSED\n\+ \jhc_utf8_getchar(void)\n\+ \{\n\+ \    return getchar_unlocked();\n\+ \}\n\+ \\n\+ \inline static int A_UNUSED\n\+ \jhc_utf8_getc(FILE *f)\n\+ \{\n\+ \    return getc_unlocked(f);\n\+ \}\n\+ \\n\+ \inline static int A_UNUSED\n\+ \jhc_utf8_putchar(int ch)\n\+ \{\n\+ \    return putchar_unlocked(ch);\n\+ \}\n\+ \\n\+ \inline static int A_UNUSED\n\+ \jhc_utf8_putc(int ch, FILE *f)\n\+ \{\n\+ \    return putc_unlocked(ch,f);\n\+ \}\n\+ \\n\+ \#endif\n\+ \"#++-- | Generated from rts\/rts\/gc_jgc_internal.h+{-# NOINLINE gc_jgc_internal_h #-}+gc_jgc_internal_h :: ByteString+gc_jgc_internal_h = unsafePerformIO $ unsafePackAddress "\+ \#ifndef GC_JGC_INTERNAL_H\n\+ \#define GC_JGC_INTERNAL_H\n\+ \\n\+ \#include \"rts/gc_jgc.h\"\n\+ \#include \"sys/bitarray.h\"\n\+ \#include \"sys/queue.h\"\n\+ \\n\+ \#if _JHC_GC == _JHC_GC_JGC\n\+ \\n\+ \struct s_arena {\n\+ \        struct s_megablock *current_megablock;\n\+ \        SLIST_HEAD(,s_block) free_blocks;\n\+ \        unsigned block_used;\n\+ \        unsigned block_threshold;\n\+ \        SLIST_HEAD(,s_cache) caches;\n\+ \        SLIST_HEAD(,s_block) monolithic_blocks;\n\+ \        SLIST_HEAD(,s_megablock) megablocks;\n\+ \        unsigned number_gcs;    // number of garbage collections\n\+ \        unsigned number_allocs; // number of allocations since last garbage collection\n\+ \};\n\+ \\n\+ \struct s_megablock {\n\+ \        void *base;\n\+ \        unsigned next_free;\n\+ \        SLIST_ENTRY(s_megablock) next;\n\+ \};\n\+ \\n\+ \struct s_block {\n\+ \        SLIST_ENTRY(s_block) link;\n\+ \        unsigned char flags;  // defined in rts/constants.h\n\+ \        unsigned char color;  // offset in words to first entry.\n\+ \        union {\n\+ \                // A normal block.\n\+ \                struct {\n\+ \                        unsigned char num_ptrs;\n\+ \                        unsigned char size;\n\+ \                        unsigned short num_free;\n\+ \                        unsigned short next_free;\n\+ \                } pi;\n\+ \                // A monolithic block.\n\+ \                struct {\n\+ \                        unsigned num_ptrs;\n\+ \                } m;\n\+ \        } u;\n\+ \        bitarray_t used[];\n\+ \};\n\+ \\n\+ \struct s_cache {\n\+ \        SLIST_ENTRY(s_cache) next;\n\+ \        SLIST_HEAD(,s_block) blocks;\n\+ \        SLIST_HEAD(,s_block) full_blocks;\n\+ \        unsigned char color;\n\+ \        unsigned char size;\n\+ \        unsigned char num_ptrs;\n\+ \        unsigned char flags;\n\+ \        unsigned short num_entries;\n\+ \        struct s_arena *arena;\n\+ \#if _JHC_PROFILE\n\+ \        unsigned allocations;\n\+ \#endif\n\+ \};\n\+ \#endif\n\+ \#endif\n\+ \"#+++
+ src/Stats.hs view
@@ -0,0 +1,239 @@+module Stats(+    -- mutable+    Stats,+    new,+    tick,+    setPrintStats,+    ticks,+    theStats,+    isEmpty,+    null,+    Stats.print,+    clear,+    combine,+    -- pure+    printStat,+    printLStat,+    Stat,+    Stats.singleton,+    Stats.singleStat,+    prependStat,+    -- monad+    MonadStats(..),+    StatT,+    StatM,+    mtick,+    mtick',+    mticks,+    runStatT,+    runStatIO,+    runStatM,+    -- combined+    tickStat,+    readStat+    ) where++import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer.Strict+import Data.IORef+import Data.Tree+import Data.List(sort,groupBy)+import Prelude hiding(null)+import System.IO.Unsafe+import qualified Data.Map as Map+import qualified Prelude(null)++import GenUtil+import StringTable.Atom+import qualified Doc.Chars as C+import qualified Util.IntBag as IB++splitUp :: Int -> String -> [String]+splitUp n str = filter (not . Prelude.null) (f n str)  where+    f 0 str = []+    f n str = case span (`notElem` "/.{") str  of+        (x,"") -> [x]+        (x,('/':rs)) -> x:f (n - 1) rs+        (x,('.':rs)) -> x:f n rs+        (x,('{':rs)) -> case span (/= '}') rs of+            (a,'}':b) -> x:a:f n b+            (a,"") -> [x,a]+            _ -> error "this can't happen"+        _ -> error "this can't happen"++print greets stats = do+    l <- toList stats+    let fs = createForest 0 $ sort [(splitUp (-1) $ fromAtom x,y) | (x,y) <- l]+    mapM_ putStrLn $ ( draw . fmap p ) (Node (greets,0) fs)  where+        p (x,0) = x+        p (x,n) = x ++ ": " ++ show n++createForest :: a -> [([String],a)] -> Forest (String,a)+createForest def xs = map f gs where+    f [(xs,ys)] =  Node (intercalate "." xs,ys) []+    f xs@((x:_,_):_) = Node (x,def) (createForest def [ (xs,ys) | (_:xs@(_:_),ys)<- xs])+    f _ = error "createForest: should not happen."+    gs = groupBy (\(x:_,_) (y:_,_) -> x == y) xs++draw :: Tree String -> [String]+draw (Node x ts0) = x : drawSubTrees ts0+  where drawSubTrees [] = []+        drawSubTrees [t] =+                {-[vLine] :-} shift lastBranch "  " (draw t)+        drawSubTrees (t:ts) =+                {-[vLine] :-} shift branch (C.vLine  ++ " ") (draw t) ++ drawSubTrees ts++        branch     = C.lTee ++ C.hLine+        lastBranch = C.llCorner ++ C.hLine++        shift first other = zipWith (++) (first : repeat other)+        --vLine = chr 0x254F++-- Pure varients++newtype Stat = Stat IB.IntBag+    deriving(Eq,Ord,Monoid)++prependStat :: String -> Stat -> Stat+prependStat name (Stat m) = Stat $ IB.fromList [ (fromAtom $ mappend (toAtom $ "{" ++ name ++ "}.")  (unsafeIntToAtom x),y) | (x,y) <- IB.toList m ]++printStat greets (Stat s) = do+    let fs = createForest 0 $ sort [(splitUp (-1) $ fromAtom (unsafeIntToAtom x),y) | (x,y) <- IB.toList s]+    mapM_ putStrLn $ ( draw . fmap p ) (Node (greets,0) fs)  where+        p (x,0) = x+        p (x,n) = x ++ ": " ++ show n++printLStat n greets (Stat s) = do+    let fs = createForest 0 $ [ (x,y) | (x,y) <- Map.toList $ Map.fromListWith (+) [( splitUp n (fromAtom (unsafeIntToAtom x)),y) | (x,y) <- IB.toList s]]+    mapM_ putStrLn $ ( draw . fmap p ) (Node (greets,0) fs)  where+        p (x,0) = x+        p (x,n) = x ++ ": " ++ show n++--------------+-- monad stats+--------------++class Monad m => MonadStats m where+    mticks' ::  Int -> Atom -> m ()+    mtickStat :: Stat -> m ()++newtype StatT m a = StatT (WriterT Stat m a)+    deriving(MonadIO, Functor, MonadFix, MonadTrans, Monad)++runStatT :: Monad m => StatT m a -> m (a,Stat)+runStatT (StatT m) =  runWriterT m++data StatM a = StatM a !Stat++instance Functor StatM where+    fmap f (StatM a s) = StatM (f a) s++instance Monad StatM where+    StatM _ s1 >> StatM y s2 = StatM y (s1 `mappend` s2)+    return x = StatM x mempty+    StatM x s1 >>= y = case y x of StatM z s2 -> StatM z (s1 `mappend` s2)++instance Stats.MonadStats StatM where+   mticks' 0 k = StatM () mempty+   mticks' n k = StatM () $ Stats.singleStat n k+   mtickStat s = StatM () s++runStatM ::  StatM a -> (a,Stat)+runStatM (StatM a s) = (a,s)++-- These are inlined so the 'toAtom' can become a caf and be shared+{-# INLINE mtick  #-}+{-# INLINE mticks #-}+mtick k = mticks 1 k+mtick' k = mticks' 1 k+mticks 0 _ = return ()+mticks n k = let k' = toAtom k in k' `seq` n `seq` mticks' n k'++instance MonadStats Identity where+    mticks' _ _ = return ()+    mtickStat _ = return ()++instance MonadReader r m => MonadReader r (StatT m) where+    ask = lift $ ask+    local f (StatT m) = StatT $ local f m++instance (Monad m, Monad (t m), MonadTrans t, MonadStats m) => MonadStats (t m) where+    mticks' n k = lift $ mticks' n k+    mtickStat s = lift $ mtickStat s++instance Monad m => MonadStats (StatT m) where+    mticks' n k = StatT $ tell (Stat $ IB.msingleton (fromAtom k) n)+    mtickStat s =  StatT $ tell s++singleton n = Stat $ IB.singleton (fromAtom $ toAtom n)++singleStat :: ToAtom a => Int -> a -> Stat+singleStat 0 _ = mempty+singleStat n k = Stat $ IB.msingleton (fromAtom $ toAtom k) n++null (Stat r) = IB.null r++instance MonadStats IO where+    mticks' 0 _ = return ()+    mticks' n a = do+        p <- readIORef printStats+        when p (putStrLn $ (show a ++ ": " ++ show n))+        ticks theStats n a+    mtickStat (Stat s) = do+        tickStat theStats (Stat s)+        p <- readIORef printStats+        when p $ forM_ (IB.toList s) $ \ (x,y) -> do+            putStrLn (show (unsafeIntToAtom x) ++ ": " ++ show y)++--------------------+-- Stateful IO stats+--------------------++newtype Stats = Stats (IORef Stat)++{-# NOINLINE theStats #-}+theStats :: Stats+theStats = unsafePerformIO new++{-# NOINLINE printStats #-}+printStats :: IORef Bool+printStats = unsafePerformIO $ newIORef False++setPrintStats :: Bool -> IO ()+setPrintStats b = writeIORef printStats b++combine :: Stats -> Stats -> IO ()+combine (Stats s1) (Stats s2) = do+    s <- readIORef s2+    modifyIORef s1 (mappend s)++new = Stats `liftM` newIORef mempty++clear (Stats h) = writeIORef h mempty++toList (Stats r) = do+    Stat s <- readIORef r+    return [(unsafeIntToAtom x,y) | (x,y) <- IB.toList s]++isEmpty (Stats r) = null `liftM` readIORef r++tick stats k = ticks stats 1 k++ticks (Stats r) c k = modifyIORef r (mappend $ singleStat c k)++-----------------+-- pure + mutable+-----------------++tickStat ::  Stats -> Stat -> IO ()+tickStat (Stats r) s = modifyIORef r (mappend s)++runStatIO :: MonadIO m =>  Stats -> StatT m a -> m a+runStatIO stats action = do+    (a,s) <- runStatT action+    liftIO $ tickStat stats s+    return a++readStat :: Stats -> IO Stat+readStat (Stats r) = readIORef r
+ src/StringTable/Atom.hsc view
@@ -0,0 +1,179 @@+{-# OPTIONS_GHC -XForeignFunctionInterface -XTypeSynonymInstances -XDeriveDataTypeable  #-}+module StringTable.Atom(+    Atom(),+    ToAtom(..),+    FromAtom(..),+    HasHash(..),+    intToAtom,+    isValidAtom,+    unsafeIntToAtom,+    atomCompare,+    unsafeByteIndex,+    dumpTable,+    dumpToFile,+    dumpStringTableStats+    ) where++#include "StringTable_cbits.h"++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.Data+import Data.Monoid+import System.IO.Unsafe (unsafePerformIO)+import Foreign.Marshal+import Foreign.Storable+import Foreign.C+import GHC.Exts+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.UTF8 as BS(fromString,toString)+import qualified Data.ByteString.Unsafe as BS++import Util.GMap+import Util.SetLike+import Util.HasSize++newtype Atom = Atom (#type atom_t)+    deriving(Typeable,Eq,Data,Ord)++class FromAtom a where+    fromAtom :: Atom -> a+    fromAtomIO :: Atom -> IO a++    fromAtomIO a = return (fromAtom a)+    fromAtom a = unsafePerformIO (fromAtomIO a)++class ToAtom a where+    toAtom :: a -> Atom+    toAtomIO :: a -> IO Atom++    toAtomIO a = return (toAtom a)+    toAtom a = unsafePerformIO (toAtomIO a)++class HasHash a where+    hash32 :: a -> Word32++instance HasHash Atom where+    hash32 a = let (x,y) = fromAtom a :: CStringLen in+        unsafePerformIO $ hash2 0 x (fromIntegral y)++instance HasHash BS.ByteString where+    hash32 bs = unsafePerformIO $ do+        BS.unsafeUseAsCStringLen bs $ \ (x,y) -> hash2 0 x (fromIntegral y)++instance HasHash String where+    hash32 s = unsafePerformIO $ withCStringLen s $+        \ (x,y) -> hash2 0 x (fromIntegral y)++instance FromAtom (String -> String) where+    fromAtom x = shows (fromAtom x :: String)++instance ToAtom Atom where+    toAtom x = x++instance FromAtom Atom where+    fromAtom x = x++instance ToAtom Char where+    toAtom x = toAtom [x]++instance ToAtom CStringLen where+    toAtomIO (cs,len) = do+        if (len > (#const MAX_ENTRY_SIZE))+            then fail "StringTable: atom is too big"+            else stAdd cs (fromIntegral len)++instance ToAtom CString where+    toAtomIO cs = do+        len <- BS.c_strlen cs+        toAtomIO (cs,fromIntegral len :: Int)++instance ToAtom String where+    toAtomIO s = toAtomIO (BS.fromString s)++instance FromAtom String where+    fromAtom = BS.toString . fromAtom++instance ToAtom BS.ByteString where+    toAtomIO bs = BS.unsafeUseAsCStringLen bs toAtomIO++instance FromAtom CStringLen where+    fromAtom a@(Atom v) = (stPtr a,fromIntegral $+        (v `shiftR` (#const ATOM_LEN_SHIFT)) .&. (#const ATOM_LEN_MASK))++instance FromAtom Word where+    fromAtom (Atom i) = fromIntegral i++instance FromAtom Int where+    fromAtom (Atom i) = fromIntegral i++instance FromAtom BS.ByteString where+    fromAtomIO a = do+        sl <- fromAtomIO a :: IO CStringLen+        BS.unsafePackCStringLen sl++instance Monoid Atom where+    mempty = toAtom BS.empty+    mappend x y = unsafePerformIO $ atomAppend x y++instance IsString Atom where+    fromString = toAtom++instance Show Atom where+    showsPrec _ atom = (fromAtom atom ++)++instance Read Atom where+    readsPrec _ s = [ (toAtom s,"") ]++intToAtom :: Monad m => Int -> m Atom+intToAtom i = if isValidAtom i then return (Atom $ fromIntegral i) else+    fail $ "intToAtom: " ++ show i++isValidAtom :: Int -> Bool+isValidAtom i = odd i++unsafeIntToAtom :: Int -> Atom+unsafeIntToAtom x = Atom (fromIntegral x)++unsafeByteIndex :: Atom -> Int -> Word8+unsafeByteIndex atom off = fromIntegral (unsafePerformIO $ peek (stPtr atom `advancePtr` off))++foreign import ccall unsafe "stringtable_lookup" stAdd :: CString -> CInt -> IO Atom+foreign import ccall unsafe "stringtable_ptr" stPtr :: Atom -> CString+foreign import ccall unsafe "stringtable_stats" dumpStringTableStats :: IO ()+foreign import ccall unsafe "dump_table" dumpTable :: IO ()+foreign import ccall unsafe "atom_append" atomAppend :: Atom -> Atom -> IO Atom+foreign import ccall unsafe "lexigraphic_compare" c_atomCompare :: Atom -> Atom -> CInt+foreign import ccall unsafe "dump_to_file" dumpToFile :: IO ()+foreign import ccall unsafe hashlittle  :: CString -> CSize -> Word32 -> IO Word32++hash2 :: Word32 -> CString -> Int -> IO Word32+hash2 init str size = hashlittle str (fromIntegral size) init++atomCompare a b = if c == 0 then EQ else if c > 0 then GT else LT where+    c = c_atomCompare a b++instance Intjection Atom where+    toIntjection i = Atom (fromIntegral i)+    fromIntjection (Atom i) = fromIntegral i++newtype instance GSet Atom = GSetAtom (IntjectionSet Atom)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,Eq,Ord,Show)+newtype instance GMap Atom v = GMapAtom (IntjectionMap Atom v)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike,Eq,Ord)++instance Functor (GMap Atom) where+    fmap f (GMapAtom (IntjectionMap mp)) = GMapAtom (IntjectionMap (fmap f mp))++instance Binary Atom where+    get = do+        x <- getWord8+        bs <- getBytes (fromIntegral x)+        return $ toAtom bs+    put a = do+        let bs = fromAtom a+        putWord8 $ fromIntegral $ BS.length bs+        putByteString bs
+ src/StringTable/StringTable_cbits.c view
@@ -0,0 +1,425 @@+#include <stdio.h>+#include <string.h>+#include <stdlib.h>+#include <inttypes.h>+#include <ctype.h>+#include <stdbool.h>+#define NDEBUG 1+#include <assert.h>++#define USE_THREADS 0++#if USE_THREADS++#include <pthread.h>++static pthread_mutex_t mutex_hash = PTHREAD_MUTEX_INITIALIZER;+static pthread_mutex_t mutex_string = PTHREAD_MUTEX_INITIALIZER;++#else++#define pthread_mutex_lock(x) ;+#define pthread_mutex_unlock(x) ;++#endif++#include "StringTable_cbits.h"+// 23 bits of chunk space to leave one bit for 'valid' flag.+// valid flag must be set to 1 for it to be a valid atom++static void dieif(bool,char *);+uint32_t hash2(uint32_t salt,unsigned char *key, int key_len);+static void print_quoted(FILE *file,unsigned char *s,int len);++// string allocation stuff++#define NUM_CHUNKS 256+#define CHUNK_SIZE 16384++#define ATOM_LEN(c)     (((atom_t)(c) >> ATOM_LEN_SHIFT) & ATOM_LEN_MASK)+#define CHUNK_INDEX(c)  (((atom_t)(c) >> 9)&0xFF)+#define CHUNK_OFFSET(c) (((atom_t)(c) >> 17) & 0x3FFF)++#define MAKE_ATOM(ci,co,len) ((((((atom_t)len) & ATOM_LEN_MASK) << ATOM_LEN_SHIFT) | ((((atom_t)ci) & 0xff) << 9) | (((atom_t)co & 0x3FFF) << 17)) | VALID_BITMASK)++#define ATOM_PTR(c) ((unsigned char *)&(stringtable_chunks[CHUNK_INDEX(c)][CHUNK_OFFSET(c)]))++#define ATOM_VALID(a) (a)++// ((a) & VALID_BITMASK)++static unsigned char first_chunk[CHUNK_SIZE];+static unsigned char *stringtable_chunks[NUM_CHUNKS] = { first_chunk };++static uint16_t current_chunk = 0;+static uint16_t next_free_offset = 0;++static atom_t+add_string(unsigned char *cs, int len)+{+    pthread_mutex_lock(&mutex_string);+        //printf("add_string(%c,%c,%i)\n",cs[0],cs[1],len);+    assert(len >= 0);+    assert(len < MAX_ENTRY_SIZE);+    assert(next_free_offset < CHUNK_SIZE);+    if(next_free_offset + 1 > CHUNK_SIZE - MAX_ENTRY_SIZE) {+        dieif(current_chunk >= NUM_CHUNKS - 1, "No more chunks");+        current_chunk++;+        assert(!stringtable_chunks[current_chunk]);+        stringtable_chunks[current_chunk] = malloc(CHUNK_SIZE);+        dieif(!stringtable_chunks[current_chunk], "error alocating memory");+        next_free_offset = 0;+    }+    memcpy(stringtable_chunks[current_chunk] + next_free_offset, cs, len);+    atom_t r = MAKE_ATOM(current_chunk, next_free_offset, len);+    assert(CHUNK_INDEX(r) == current_chunk);+    assert(CHUNK_OFFSET(r) == next_free_offset);+    assert(ATOM_PTR(r) == stringtable_chunks[current_chunk] + next_free_offset);+    assert(ATOM_LEN(r) == len);+    next_free_offset += len;+    assert(next_free_offset < CHUNK_SIZE);+    assert(current_chunk < NUM_CHUNKS);+    pthread_mutex_unlock(&mutex_string);+    return r;+}++// hashtable stuff++#define KEEP_HASH 2++#define CUCKOO_HASHES 2U+#define CUCKOO_BUCKETS 2U++typedef uint32_t hash_t;++struct hentry {+#if KEEP_HASH+        hash_t hashes[CUCKOO_HASHES];+#endif+        atom_t atom;+};++#define INIT_SIZE 2+static uint32_t hsize = INIT_SIZE;+static struct hentry init_htable[(1 << INIT_SIZE) * CUCKOO_HASHES];+static struct hentry *htable = init_htable;++#define HASHSIZE  (1 << hsize)+#define HASHMASK (HASHSIZE - 1)++#define INDEX_HASH(i)  ((i) / HASHSIZE)+#define HASH_INDEX(h,x) ((h * HASHSIZE) + (HASHMASK & ((uint32_t)x)))++#define HASH_BUCKET(x,b) ((((x) + (b)) % HASHSIZE) + (INDEX_HASH(x)*HASHSIZE))++#define DEPTH_LIMIT 512++static void hash_insert(struct hentry x);++static void+fast_insert(int t, int tb, struct hentry hb) {+        hash_insert(hb);+}++#ifndef NDEBUG++static bool+atom_exists(atom_t a) {+        for(int i = 0; i < HASHSIZE*CUCKOO_HASHES; i++) {+                if(a == htable[i].atom) return true;+        }+        return false;+}+static bool+item_exists(unsigned char *cs, int len) {+        for(int i = 0; i < HASHSIZE*CUCKOO_HASHES; i++) {+                atom_t a = htable[i].atom;+                if(ATOM_VALID(a)) {+                    if(len == ATOM_LEN(a) && !memcmp(ATOM_PTR(a),cs,len))+                        return true;+                }+        }+        return false;+}++#endif++void+dump_to_file(void) {+        FILE *file = fopen("atom.dump","w");+        for(int i = 0; i < HASHSIZE*CUCKOO_HASHES; i++) {+                atom_t a = htable[i].atom;+                if(ATOM_VALID(a)) {+                        fprintf(file,"%u:",ATOM_LEN(a));+                        print_quoted(file, ATOM_PTR(a),ATOM_LEN(a));+                        fwrite("\n",1,1,file);+                }+        }+}++void+dump_table(void) {+        for(int i = 0; i < HASHSIZE*CUCKOO_HASHES; i++) {+                atom_t a = htable[i].atom;+                if(ATOM_VALID(a)) {+                        printf("%p %u: ",ATOM_PTR(a),ATOM_LEN(a));+                        fwrite(ATOM_PTR(a),1,ATOM_LEN(a),stdout);+                        fwrite("\n",1,1,stdout);+                }+        }+}++static void+grow_table(void) {+ //   fprintf(stderr,"grow_table[[[\n");+        uint32_t os = (1 << hsize++) * CUCKOO_HASHES;+        struct hentry *ot = htable;+        htable = calloc(sizeof(struct hentry),CUCKOO_HASHES * (1 << hsize));++        for(int i = 0; i < os; i++) {+                if(ATOM_VALID(ot[i].atom))+                        fast_insert(0,0,ot[i]);+        }+        if(ot != init_htable) free(ot);+//    fprintf(stderr,"]]]\n");+}++uint32_t hashlittle(const void *key, size_t length, uint32_t initval);+#if KEEP_HASH+#define FHASH(x,i) ((x).hashes[i])+#else+#define FHASH(x,i) (hashlittle(ATOM_PTR((x).atom),ATOM_LEN((x).atom),i))+#endif++static void+hash_insert(struct hentry x) {+        assert(ATOM_VALID(x.atom));+//         fprintf(stderr,"hash_insert(%x,%p:%i,%x,%x,[%x,%x]", x.atom, ATOM_PTR(x.atom), ATOM_LEN(x.atom), x.hashes[0], x.hashes[1],HASH_INDEX(0,x.hashes[0]),HASH_INDEX(1,x.hashes[1]));+        assert(!atom_exists(x.atom));+        assert(!item_exists(ATOM_PTR(x.atom),ATOM_LEN(x.atom)));+        atom_t start = x.atom;+        for(int loop = 0; loop < DEPTH_LIMIT;loop++) {+                for(int i = 0; i < CUCKOO_HASHES; i++) {+//                        int e = HASH_INDEX(i,FHASH(x,i));+                        for(int j = 0; j < CUCKOO_BUCKETS; j++) {+                                //#struct hentry *b = &(htable[(e + j) & HASHJMASK ]);+                                //struct hentry *b = &htable[HASH_BUCKET(e,j)];+                                struct hentry *b = &htable[HASH_INDEX(i,FHASH(x,i) + j)];+                                if(!ATOM_VALID(b->atom)) {+                                        *b = x;+//                                        fprintf(stderr,")\n");+                                        return;+                                }+                                struct hentry tb = x;+                                x = *b;+                                *b = tb;+                        }+                        // struct hentry *b = &(htable[e]);+                }+                if(x.atom == start) {+                        break;+                }+        }+        grow_table();+//        fprintf(stderr,"R");+        return hash_insert(x);+}++static void+print_quoted(FILE *file,unsigned char *s,int len)+{+        for(int i = 0;i < len; i ++) {+                switch(s[i]) {+                case '\n': fputs("\\n",file); continue;+                case '\r': fputs("\\r",file); continue;+                case '\t': fputs("\\t",file); continue;+                default: ;+                }+                if(isprint(s[i]))+                        fputc(s[i],file);+                else+                        fprintf(file,"\\x%2.2X", (unsigned)s[i]);+        }+}++atom_t+stringtable_lookup(unsigned char *cs, int len)+{+//        static FILE *file = NULL;+//        if(!file)+//                file = fopen("atom.lookup","w");+//        fprintf(file,"stringtable_lookup(");+//        print_quoted(file,cs,len);+//        fprintf(file,")\n");+        pthread_mutex_lock(&mutex_hash);+        assert(len >= 0);+        assert(len < MAX_ENTRY_SIZE);+        hash_t h[CUCKOO_HASHES];+        for(uint32_t i = 0; i < CUCKOO_HASHES; i++) {+                h[i] = hashlittle(cs,len,i);+                //int e = HASH_INDEX(i,h[i]);+                for(int j = 0; j < CUCKOO_BUCKETS; j++) {+                        //struct hentry *b = &htable[(e + i) & HASHJMASK ];+                        //struct hentry *b = &htable[HASH_BUCKET(e,j)];+                        struct hentry *b = &htable[HASH_INDEX(i,h[i] + j)];+#if KEEP_HASH+                        if (ATOM_VALID(b->atom) && h[i] == b->hashes[i] && len == ATOM_LEN(b->atom) &&  !memcmp(ATOM_PTR(b->atom),cs,len)) {+                            pthread_mutex_unlock(&mutex_hash);+                            return b->atom;+                        }+#else+                        if (ATOM_VALID(b->atom) && len == ATOM_LEN(b->atom) && !memcmp(ATOM_PTR(b->atom),cs,len)) {+                            pthread_mutex_unlock(&mutex_hash);+                            return b->atom;+                        }+#endif+                }+        }+        atom_t na = add_string(cs,len);+        struct hentry hb;+        hb.atom = na;+#if KEEP_HASH+        memcpy(hb.hashes,h,sizeof hb.hashes);+#endif+        hash_insert(hb);+        pthread_mutex_unlock(&mutex_hash);+        return na;+}++int+lexigraphic_compare(atom_t x, atom_t y)+{+    int xl = ATOM_LEN(x);+    int yl = ATOM_LEN(y);+    return memcmp(ATOM_PTR(x),ATOM_PTR(y),xl < yl ? xl : yl) || xl - yl;+}++atom_t+atom_append(atom_t x,atom_t y)+{+    unsigned char *xs,*ys;+    int xl,yl;++    xl = stringtable_find(x,&xs);+    yl = stringtable_find(y,&ys);++    unsigned char buf[MAX_ENTRY_SIZE];++    memcpy(buf,xs,xl);+    memcpy(buf + xl,ys,yl);++    return stringtable_lookup(buf,xl + yl);+}++unsigned char *+stringtable_ptr(atom_t cl)+{+        assert(ATOM_VALID(cl));+        return ATOM_PTR(cl);+}++int+stringtable_get(atom_t cl, char buf[MAX_ENTRY_SIZE])+{+        assert(ATOM_VALID(cl));+        memcpy(buf,ATOM_PTR(cl),ATOM_LEN(cl));+        return ATOM_LEN(cl);+}++int+stringtable_find(atom_t cl, unsigned char **res)+{+        assert(ATOM_VALID(cl));+        *res = ATOM_PTR(cl);+        return ATOM_LEN(cl);+}++void+stringtable_stats(void)+{+    unsigned static_memory = sizeof(stringtable_chunks);+    printf("Static Memory: %u\n", static_memory);+    unsigned dynamic_memory = (current_chunk + 1) * CHUNK_SIZE;+    unsigned data_memory = current_chunk*CHUNK_SIZE + next_free_offset;;+    printf("Used Chunks: %u/%u - %u bytes\n", current_chunk + 1, NUM_CHUNKS, data_memory);+    unsigned num_entries = 0;+    unsigned hash_types[CUCKOO_HASHES];+    memset(hash_types,0,sizeof hash_types);+    unsigned num_total = 0;+    for(int i = 0; i < HASHSIZE * CUCKOO_HASHES; i++) {+            num_total++;+            dynamic_memory += sizeof(struct hentry);+            if(ATOM_VALID(htable[i].atom)) {+                    num_entries++;+                    hash_types[i / HASHSIZE]++;+            }+    }++    for(int i = 0; i < CUCKOO_HASHES; i++)+            printf("Hash Table  %i: %u\n", i, hash_types[i]);++    printf("Usage: %u/%u %.3f%%\n", num_entries, num_total, (double)num_entries * 100.0 / num_total);++    printf("Dynamic Memory: %u\n", dynamic_memory);+    printf("Storage Efficiency: %.3f%%\n", (double)data_memory * 100.0/ dynamic_memory);++}++static void+dieif(bool w,char *str)+{+    if(w) {+        fprintf(stderr, "stringlib: %s\n", str);+        exit(1);+    }+}++// hash functions+/*+uint32_t+hash2(uint32_t salt, unsigned char *key, int key_len)+{+        uint32_t hash = salt;+        for (int i = 0; i < key_len; i++) {+                hash += key[i];+                hash += (hash << 10);+                hash ^= (hash >> 6);+        }+        hash += (hash << 3);+        hash ^= (hash >> 11);+        hash += (hash << 15);+        return hash;+}++int+main(int argc, char *argv[])+{+    unsigned char buf[MAX_ENTRY_SIZE];+    while(fgets((char *)buf,MAX_ENTRY_SIZE,stdin)) {+        buf[MAX_ENTRY_SIZE - 1] = '\0';+        unsigned len = strlen((char *)buf);+        if(!len) continue;+        if(buf[len - 1] == '\n') buf[--len] = '\0';+        stringtable_lookup(buf,len);+        //printf("%x: %s\n", a, buf);++    }++    dump_table();+    stringtable_stats();++    return 0;+}+static hash_t+hash3(uint32_t salt, unsigned char* str, size_t len)+{+        const uint32_t fnv_prime = 0x811C9DC5;+        unsigned int hash      = salt;+        for(int i = 0; i < len; i++) {+                hash *= fnv_prime;+                hash ^= str[i];+                hash ^= salt;+        }+        return hash;+}+*/
+ src/StringTable/StringTable_cbits.h view
@@ -0,0 +1,22 @@+#ifndef ST_CBITS_H+#define ST_CBITS_H++#include <stdint.h>++#define MAX_ENTRY_SIZE 256+#define VALID_BITMASK 0x1++// always shift, then mask+#define ATOM_LEN_MASK 0xff+#define ATOM_LEN_SHIFT 1++typedef uint32_t atom_t;+++atom_t stringtable_lookup(unsigned char *cs, int len);+void stringtable_stats(void);+int stringtable_find(atom_t cl, unsigned char **res);+unsigned char *stringtable_ptr(atom_t cl);+++#endif
+ src/Support/CFF.hs view
@@ -0,0 +1,283 @@+{-# OPTIONS -funbox-strict-fields  -O2 #-}+{-# LANGUAGE BangPatterns #-}++-- chunked file format.+-- A generalization of the PNG format for user defined file formats.++module Support.CFF(+    ChunkType(),+    FileType(),+    FileOffset(),+    ChunkLength(),+    chunkType,+    isCritical,+    isPrivate,+    isSafeToCopy,+    readCFFHeader,+    readCFFInfo,+    readCFF,+    bsCFF,+    lbsCFF,+    mkCFFfile,+    readChunk,+    lazyWriteCFF,+    writeCFF+    )where++import Control.Monad+import Data.Bits+import Data.Char+import Data.Word+import System.IO+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS++type FileOffset = Word+type ChunkLength = Word++-- the file's magic number is as follows:+--+-- 0x89      - high bit set, to check for 8 bit transmission errors and to avoid being treated as a text file+-- 3 bytes   - identifies the particular file format. i.e. 'PNG' or 'JHC'+-- 0x0D 0x0A - DOS style line ending, to detect errors.+-- 0x1A      - EOF marker, to avoid corrupting the screen when typed under dos/windows+-- 0x0A      - unix EOL marker, to detect line conversion errors++-----------------------------------+-- Routines dealing with ChunkTypes+-----------------------------------++type FileType = ChunkType+newtype ChunkType = ChunkType Word32+    deriving(Eq,Ord)++instance Show ChunkType where+    showsPrec _ (ChunkType w) xs = b 3:b 2:b 1:b 0:xs where+        b n = chr $ fromIntegral ((w `shiftR` (8 * n)) .&. 0xFF)++instance Read ChunkType where+    readsPrec _ (b1:b2:b3:b4:xs) = [(chunkType [b1,b2,b3,b4],xs)]+    readsPrec _ _ = []++chunkType :: String -> ChunkType+chunkType [b1,b2,b3,b4] = bytesToChunkType (fi b1) (fi b2) (fi b3) (fi b4) where+    fi = fromIntegral . ord+chunkType [b1,b2,b3] = chunkType [b1,b2,b3,' ']+chunkType _ = error "chunkType: not a chunk."++-- critical if the first letter is capitalized+isCritical :: ChunkType -> Bool+isCritical (ChunkType w) =  w .&. 0x20000000 == 0++-- private if the second letter is capitalized+isPrivate :: ChunkType -> Bool+isPrivate  (ChunkType w) =  w .&. 0x00200000 == 0++-- chunk should be copied if unrecognized by an editor+isSafeToCopy :: ChunkType -> Bool+isSafeToCopy (ChunkType w) =  w .&. 0x00000020 == 0++lbsCFF :: Monad m => LBS.ByteString -> m (FileType,[(ChunkType,LBS.ByteString)])+lbsCFF bs = ans bs where+    ans bs' = do+        let checkByte n b = do+                unless ((bs `LBS.index` n) == b) $ fail "bsCFF: invalid chunked file"+            bs = LBS.take 8 bs'+        when (LBS.length bs < 8) $ fail "bsCFF: chunked file is too short"+        checkByte 0 0x89+        checkByte 4 0x0d+        let b1 = bs `LBS.index` 1+            b2 = bs `LBS.index` 2+            b3 = bs `LBS.index` 3+        checkByte 5 0x0a+        checkByte 6 0x1a+        checkByte 7 0x0a+        let header =  bytesToChunkType b1 b2 b3 (fromIntegral $ ord ' ')+        return (header,readRest (LBS.drop 8 bs))++    bsWord32 :: LBS.ByteString -> Word32+    bsWord32 bs = w where+        b1 = bs `LBS.index` 0+        b2 = bs `LBS.index` 1+        b3 = bs `LBS.index` 2+        b4 = bs `LBS.index` 3+        ChunkType w = bytesToChunkType b1 b2 b3 b4++    readRest bs = f bs where+        f bs | LBS.null bs = []+        f bs = (ct,bdata):f (LBS.drop 4 brest) where+            len = bsWord32 bs+            ct = ChunkType $ bsWord32 (LBS.drop 4 bs)+            (bdata,brest)  = LBS.splitAt (fromIntegral len) (LBS.drop 8 bs)++bsCFF :: Monad m => BS.ByteString -> m (FileType,[(ChunkType,BS.ByteString)])+bsCFF bs = ans bs where+    ans bs = do+        let checkByte n b = do+                unless ((bs `BS.index` n) == b) $ fail "bsCFF: invalid chunked file"+        when (BS.length bs < 8) $ fail "bsCFF: chunked file is too short"+        checkByte 0 0x89+        checkByte 4 0x0d+        let b1 = bs `BS.index` 1+            b2 = bs `BS.index` 2+            b3 = bs `BS.index` 3+        checkByte 5 0x0a+        checkByte 6 0x1a+        checkByte 7 0x0a+        let header =  bytesToChunkType b1 b2 b3 (fromIntegral $ ord ' ')+        return (header,readRest (BS.drop 8 bs))++    bsWord32 :: BS.ByteString -> Word32+    bsWord32 bs = w where+        b1 = bs `BS.index` 0+        b2 = bs `BS.index` 1+        b3 = bs `BS.index` 2+        b4 = bs `BS.index` 3+        ChunkType w = bytesToChunkType b1 b2 b3 b4++    readRest bs = f bs where+        f bs | BS.null bs = []+        f bs = (ct,bdata):f (BS.drop 4 brest) where+            len = bsWord32 bs+            ct = ChunkType $ bsWord32 (BS.drop 4 bs)+            (bdata,brest)  = BS.splitAt (fromIntegral len) (BS.drop 8 bs)++mkCFFHeader :: FileType -> BS.ByteString+mkCFFHeader (ChunkType ft) = BS.pack [0x89,b1,b2,b3,0x0d,0x0a,0x1a,0x0a] where+    (b1,b2,b3,_) = word32ToBytes ft++readCFFHeader :: Handle -> IO ChunkType+readCFFHeader h = do+    let checkByte b = do+            z <- getByte h+            unless (z == b) $ fail "readCFFInfo: invalid chunked file"+    checkByte 0x89+    b1 <- getByte h+    b2 <- getByte h+    b3 <- getByte h+    checkByte 0x0d+    checkByte 0x0a+    checkByte 0x1a+    checkByte 0x0a+    return $ bytesToChunkType b1 b2 b3 (fromIntegral $ ord ' ')++writeCFFHeader :: Handle -> FileType -> IO ()+writeCFFHeader h ft = BS.hPut h (mkCFFHeader ft)++readCFFInfo :: Handle -> IO (ChunkType,[(ChunkType,FileOffset,ChunkLength)])+readCFFInfo h = do+    cffType <- readCFFHeader h+    let readChunk !fo = do+            b <- hIsEOF h+            if b then return [] else do+            len <- readWord32 h+            ct <- readChunkType h+            hSeek h RelativeSeek (fromIntegral len)+            _csum  <- readWord32 h+            xs <- readChunk (fo + fromIntegral len + 12)+            return ((ct,fo + 8,fromIntegral len):xs)++    xs <- readChunk (8::FileOffset)+    return (cffType,xs)++readCFF :: Handle -> IO (ChunkType,[(ChunkType,BS.ByteString)])+readCFF h = do+    cffType <- readCFFHeader h+    let readChunk = do+            b <- hIsEOF h+            if b then return [] else do+            len <- readWord32 h+            ct <- readChunkType h+            bs <- BS.hGet h (fromIntegral len)+            _csum <- readWord32 h -- TODO verify checksum+            xs <- readChunk+            return ((ct,bs):xs)+    xs <- readChunk+    return (cffType,xs)++-- this verifies a cff is of a specific type, and reads a specific chunk only.+readChunk :: Handle -> ChunkType -> ChunkType -> IO BS.ByteString+readChunk h eft ect = do+    cffType <- readCFFHeader h+    when (cffType /= eft) $ fail "readChunk: CFF file of incorrect type"+    let readChunk = do+            b <- hIsEOF h+            if b then fail "readChunk: specified chunk was not found" else do+            len <- readWord32 h+            ct <- readChunkType h+            if ct == ect then do BS.hGet h (fromIntegral len) else do+                hSeek h RelativeSeek (fromIntegral len + 4)+                readChunk+    readChunk++mkCFFfile :: FileType -> [(ChunkType,LBS.ByteString)] -> LBS.ByteString+mkCFFfile ft cs = LBS.fromChunks [mkCFFHeader ft] `LBS.append` LBS.concat (concatMap f cs) where+    f (ChunkType ct,bs) = [hl,bs,zero]  where+        (b1,b2,b3,b4) = word32ToBytes ct+        (l1,l2,l3,l4) = word32ToBytes (fromIntegral $ LBS.length bs)+        hl = LBS.pack [l1,l2,l3,l4,b1,b2,b3,b4]+zero :: LBS.ByteString+zero = LBS.pack [0,0,0,0]++writeCFF :: Handle -> ChunkType -> [(ChunkType,BS.ByteString)] -> IO ()+writeCFF h ft xs = do+    writeCFFHeader h ft+    let writeChunk (ChunkType ct,bs) = do+            writeWord32 h (fromIntegral $ BS.length bs)+            writeWord32 h ct+            BS.hPut h bs+            writeWord32 h 0 -- TODO proper checksum+    mapM_ writeChunk xs++lazyWriteCFF :: Handle -> ChunkType -> [(ChunkType,LBS.ByteString)] -> IO ()+lazyWriteCFF h ft xs = do+    writeCFFHeader h ft+    let writeChunk (ChunkType ct,bs) = do+            writeWord32 h (fromIntegral $ LBS.length bs)+            writeWord32 h ct+            LBS.hPut h bs+            writeWord32 h 0 -- TODO proper checksum+    mapM_ writeChunk xs++-------------------------------------------------+-- Various routines for reading and writing bytes+-------------------------------------------------++getByte :: Handle -> IO Word8+getByte h = liftM (fromIntegral . ord) (hGetChar h)++writeByte :: Handle -> Word8 -> IO ()+writeByte h b = hPutChar h (chr $ fromIntegral b)++bytesToChunkType :: Word8 -> Word8 -> Word8 -> Word8 -> ChunkType+bytesToChunkType b1 b2 b3 b4 = ChunkType $ bytesToWord32 b1 b2 b3 b4++word32ToBytes :: Word32 -> (Word8,Word8,Word8,Word8)+word32ToBytes w = (b 3,b 2,b 1,b 0) where+        b n = fromIntegral ((w `shiftR` (8 * n)) .&. 0xFF)++bytesToWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+bytesToWord32 b1 b2 b3 b4 = b 3 b1 .|. b 2 b2 .|. b 1 b3 .|. b 0 b4  where+    b n c = (fromIntegral c) `shiftL` (8 * n)++readChunkType :: Handle -> IO ChunkType+readChunkType h = do+    w <- readWord32 h+    return $ ChunkType w++readWord32 :: Handle -> IO Word32+readWord32 h = do+    b1 <- getByte h+    b2 <- getByte h+    b3 <- getByte h+    b4 <- getByte h+    let ChunkType ct = bytesToChunkType b1 b2 b3 b4+    return ct++writeWord32 :: Handle -> Word32 -> IO ()+writeWord32 h w = do+    let (b1,b2,b3,b4) = word32ToBytes w+    writeByte h b1+    writeByte h b2+    writeByte h b3+    writeByte h b4
+ src/Support/Cabal.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module Support.Cabal (getDataFileNameMaybe) where+#ifdef WITH_CABAL+import Paths_ajhc (getDataFileName)+#endif++getDataFileNameMaybe :: FilePath -> IO (Maybe FilePath)+#ifdef WITH_CABAL+getDataFileNameMaybe s = do f <- getDataFileName s+                            return $ Just f+#else+getDataFileNameMaybe _ = return Nothing+#endif
+ src/Support/CanType.hs view
@@ -0,0 +1,22 @@+module Support.CanType where++import Control.Monad.Error()++-- This is a simple routine meant to do the minimum amount of work to get the type of something+class CanType a where+    type TypeOf a+    getType :: a -> (TypeOf a)++instance CanType e => CanType [e] where+    type TypeOf [e] = [TypeOf e]+    getType es = map getType es++instance CanType e => CanType (Maybe e) where+    type TypeOf (Maybe e) = Maybe (TypeOf e)+    getType Nothing = Nothing+    getType (Just x) = Just (getType x)++instance (CanType e1, CanType e2) => CanType (Either e1 e2) where+    type TypeOf (Either e1 e2) = Either (TypeOf e1) (TypeOf e2)+    getType (Left x) = Left $ getType x+    getType (Right x) = Right $ getType x
+ src/Support/Compat.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+module Support.Compat where++-- This module is meant to contain code+-- that only exists for compatability between platforms++import Control.Exception++#if __GLASGOW_HASKELL__ < 610+type SomeException' = Exception+#else+type SomeException' = SomeException+#endif
+ src/Support/CompatMingw32.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+module Support.CompatMingw32 (+  createLinkCompat,+  raiseSigIntCompat,+  noEscapePath,+  systemCompat+  ) where++import System.Process+import System.Exit+#ifdef mingw32_HOST_OS+import System.Directory+import System.Win32.Console+#else+import System.Posix.Files+import System.Posix.Signals+#endif++createLinkCompat :: FilePath -> FilePath -> IO ()+#ifdef mingw32_HOST_OS+createLinkCompat = copyFile+#else+createLinkCompat = createLink+#endif++raiseSigIntCompat :: IO ()+#ifdef mingw32_HOST_OS+raiseSigIntCompat = generateConsoleCtrlEvent cTRL_C_EVENT 0+#else+raiseSigIntCompat = raiseSignal sigINT+#endif++noEscapePath :: String -> String+#ifdef mingw32_HOST_OS+-- Windows filepath backslash confuses jhc's lexer with escape code.+noEscapePath = replace '\\' '/'+  where replace :: Eq a => a -> a -> [a] -> [a]+        replace x y = map (\z -> if z == x then y else z)+#else+noEscapePath = id+#endif++systemCompat :: String -> IO ExitCode+#ifdef mingw32_HOST_OS+systemCompat s = system $ "sh -c \"" ++ s ++ "\""+#else+systemCompat = system+#endif
+ src/Support/FreeVars.hs view
@@ -0,0 +1,26 @@+module Support.FreeVars where++import Data.Monoid++class Monoid b => FreeVars a b where+    freeVars ::  a -> b++instance  Monoid x => FreeVars () x where+    freeVars () = mempty++instance (FreeVars x b, FreeVars y b) => FreeVars (x,y) b where+    freeVars (x,y) = freeVars x `mappend` freeVars y++instance (FreeVars x b, FreeVars y b, FreeVars z b) => FreeVars (x,y,z) b where+    freeVars (x,y,z) = freeVars x `mappend` freeVars y `mappend` freeVars z++instance FreeVars a b => FreeVars [a] b where+    freeVars as = mconcat (map freeVars as)++instance FreeVars a b => FreeVars (Maybe a) b where+    freeVars (Just x) = freeVars x+    freeVars Nothing = mempty++instance (FreeVars x b, FreeVars y b) => FreeVars (Either x y) b where+    freeVars (Left x) = freeVars x+    freeVars (Right y) = freeVars y
+ src/Support/IniParse.hs view
@@ -0,0 +1,137 @@+module Support.IniParse(parseIniFiles) where++import Control.Monad.State+import Data.Char+import Data.List+import GenUtil+import qualified Data.Foldable as Seq+import qualified Data.Map as Map+import qualified Data.Sequence as Seq++-- quick and dirty parser.++type St = (Int,FilePath,String)++newtype P a = P (State St a)+    deriving(Monad,MonadState St)++third (_,_,x) = x++look :: P String+look = gets third++discard :: Int -> P ()+discard n = do+    (fl,fp,s) <- get+    let (x,y) = splitAt n s+    put (fl + length (filter (== '\n') x),fp, y)++abort :: String -> P a+abort msg = do+    (l,fp,_)  <- get+    fail $ fp ++ ":" ++ show l ++ ": " ++ msg++dropSpace = do+    x <- look+    case x of+        ';':_ -> pdropWhile ('\n' /=) >> dropSpace+        c:_ | isSpace c -> pdropWhile isSpace >> dropSpace+        _ -> return ()++pdropWhile f  = do+    x <- look+    case x of+        c:_ | f c -> discard 1 >> pdropWhile f+        _ -> return ()++ptakeWhile f  = do+    x <- look+    let ts = takeWhile f x+    discard (length ts)+    return ts++pThings ch rs zs  = ans where+    ans = look >>= \x -> case x of+        '[':_ -> do+            hv <- pHeader+            dropSpace+            pThings hv Seq.empty (zs Seq.|> (ch,rs))+        _:_ -> do+            v <- pValue+            dropSpace+            pThings ch (rs Seq.|> v) zs+        [] -> return (zs Seq.|> (ch,rs))++trim = rbdropWhile isSpace++expect w = do+    cs <- look+    if w `isPrefixOf` cs then discard (length w) else abort ("expected " ++ show w)++pValue = do+    n <- ptakeWhile (`notElem` ['\n','='])+    expect "="+    rs <- ptakeWhile (/= '\n')+    return (trim n, trim rs)++pHeader = do+    expect "["+    n <- ptakeWhile (`notElem` "]\n")+    expect "]"+    return (trim n)++-- We use laziness cleverly to avoid repeating work+processIni :: Seq.Seq (String,Seq.Seq (String,String)) -> Map.Map String (Seq.Seq (String,String))+processIni iniRaw = iniMap' where+    iniMap,iniMap' :: Map.Map String (Seq.Seq (String,String))+    iniMap = Map.fromListWith (flip (Seq.><)) (Seq.toList iniRaw)+    iniMap' = Map.map expandChains iniMap+    expandChains x = join (fmap ecp x)+    ecp :: (String,String) -> Seq.Seq (String,String)+    ecp ("merge",v) = Map.findWithDefault Seq.empty v iniMap'+    ecp x = Seq.singleton x+--    ans = Map.map (\c -> Seq.foldl res Map.empty c) iniMap'+--    res mp (k,v) | Just r <- getPrefix "+" (reverse k) = Map.insertWith f (reverse $ dropWhile isSpace r) v mp where+--        f y x = x ++ " " ++ y+--    res mp (k,v) = Map.insert k v mp++parseIniFile :: FilePath -> IO (Seq.Seq (String,Seq.Seq (String,String)))+parseIniFile fp = readFile fp >>= parseIniRaw fp++parseIniRaw :: String -> String -> IO (Seq.Seq (String,Seq.Seq (String,String)))+parseIniRaw fp c = do+    let P act = dropSpace >> pThings "default" Seq.empty Seq.empty+    return $ evalState act (0,fp,c)++parseIniFiles+    :: Bool          -- ^ whether verbose is enabled+    -> String        -- ^ raw ini contents to parse first+    -> [FilePath]    -- ^ the files (in order) we attempt to parse+    -> [String]      -- ^ the m-flags+    -> IO (Map.Map String String)+parseIniFiles verbose raw fs ss = do+    let rf fn = iocatch (do c <- parseIniFile fn; pverb ("reading " ++ fn); return c) (\_ -> return Seq.empty)+        pverb s = if verbose then putErrLn s else return ()+    rawp <- parseIniRaw "(builtin targets.ini)" raw+    fsc <- mapM rf fs+    let pini = processIni (foldr (Seq.><) Seq.empty (rawp:fsc))+        f (x:xs) cm = case span (/= '=') x of+            (be,'=':re) -> f xs (res cm (be,re)) -- f xs (Map.insert be re cm)+            ~(be,[]) -> f xs (Seq.foldl res cm (Map.findWithDefault Seq.empty be pini))+        f [] cm = cm+--    ans = Map.map (\c -> Seq.foldl res Map.empty c) iniMap'+        res mp (k,v) | Just r <- getPrefix "+" (reverse k) = Map.insertWith f (reverse $ dropWhile isSpace r) v mp where+            f y x = x ++ " " ++ y+        res mp (k,v) = Map.insert k v mp+    return (f ss Map.empty)++--main = do+--    as <- getArgs+--    is <- mapM parseIniFile as+--    let pi = processIni (foldr (Seq.><) Seq.empty is)+--+--    print "proc"+--    let f (h,rs) = do+--            putStrLn h+--            mapM_ (\x -> putStr "    " >>  print x) (Map.toList rs)+--    mapM_ f (Map.toList pi)
+ src/Support/MD5.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS -funbox-strict-fields  -O2 #-}+module Support.MD5(+    Hash(), emptyHash, md5,md5file,md5lazy,md5lazyIO,+    md5show32,md5Bytes,md5String,md5Handle,hashToBytes) where++import Control.Monad+import Data.Binary+import Data.Char+import Data.Bits+import System.IO.Unsafe (unsafePerformIO)+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable+import Foreign.C+import System.IO+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Unsafe as BS++data Hash = Hash !Word32 !Word32 !Word32 !Word32+    deriving(Eq,Ord)++md5 :: BS.ByteString -> Hash+md5 bs = unsafePerformIO $ allocaBytes 16 $ \digest -> do+        BS.unsafeUseAsCStringLen bs $ \ (x,y) -> md5Data (castPtr x) (fromIntegral y) digest+        readDigest digest++md5lazy :: LBS.ByteString -> Hash+md5lazy lbs = unsafePerformIO $ md5lazyIO lbs++md5lazyIO :: LBS.ByteString -> IO Hash+md5lazyIO lbs = do+    allocaBytes (fromIntegral $ get_md5_statesize) $ \msp -> do+        let ms = MState msp+        md5_init ms+        forM_ (LBS.toChunks lbs) $ \bs -> do+            BS.unsafeUseAsCStringLen bs $ \ (x,y) -> md5_append ms (castPtr x) (fromIntegral y)+        allocaBytes 16 $ \digest -> do+            md5_finish ms digest+            readDigest digest++readDigest digest = do+    w1 <- peekWord32 digest 0+    w2 <- peekWord32 digest 4+    w3 <- peekWord32 digest 8+    w4 <- peekWord32 digest 12+    return $ Hash w1 w2 w3 w4++peekWord32 ptr off = do+    b1 <- peekByteOff ptr off       :: IO Word8+    b2 <- peekByteOff ptr (off + 1) :: IO Word8+    b3 <- peekByteOff ptr (off + 2) :: IO Word8+    b4 <- peekByteOff ptr (off + 3) :: IO Word8+    let fi = fromIntegral :: Word8 -> Word32+    return (fi b1 `shiftL` 24 .|. fi b2 `shiftL` 16 .|. fi b3 `shiftL` 8 .|. fi b4)++instance Binary Hash where+    put (Hash a b c d) = put a >> put b >> put c >> put d+    get = return Hash `ap` get `ap` get `ap` get `ap` get++md5file :: FilePath -> IO Hash+md5file fp = md5lazy `fmap` LBS.readFile fp++newtype MState = MState (Ptr MState)++foreign import ccall unsafe "md5_data" md5Data :: Ptr Word8 -> CInt -> Ptr Word8 -> IO ()+foreign import ccall unsafe md5_init  :: MState -> IO ()+foreign import ccall unsafe md5_append :: MState -> Ptr Word8 -> CInt -> IO ()+foreign import ccall unsafe md5_finish :: MState -> Ptr Word8 -> IO ()+foreign import ccall unsafe get_md5_statesize :: CInt++hashToBytes :: Hash -> [Word8]+hashToBytes (Hash a b c d) = tb a . tb b . tb c . tb d $ [] where+    tb :: Word32 -> [Word8] -> [Word8]+    tb n = showIt 4 n+    showIt :: Int -> Word32 -> [Word8] -> [Word8]+    showIt 0 _ r = r+    showIt i x r = case quotRem x 256 of+                       (y, z) -> let c = fromIntegral z+                                 in c `seq` showIt (i-1) y (c:r)++md5show32 :: Hash -> String+md5show32 hash = f [] (hashToBytes hash) where+    f cs [] = cs+    f cs (o1:o2:o3:o4:o5:rest) = f ns rest where+        i1 = o1 `shiftR` 3+        i2 = (o1 `shiftL` 2 .|. o2 `shiftR` 6) .&. 0x1f+        i3 = o2 `shiftR` 1 .&. 0x1f+        i4 = (o2 `shiftL` 4 .|. o3 `shiftR` 4) .&. 0x1f+        i5 = (o3 `shiftL` 1 .|. o4 `shiftR` 7) .&. 0x1f+        i6 = o4 `shiftR` 2 .&. 0x1f+        i7 = (o4 `shiftL` 3 .|. o5 `shiftR` 5) .&. 0x1f+        i8 = o5 .&. 0x1f+        ns = g i1:g i2:g i3:g i4:g i5:g i6:g i7:g i8:cs+        g x | x <= 9 = chr (ord '0' + fromIntegral x)+            | otherwise = chr (ord 'a' + fromIntegral x - 10)+    f cs ns = reverse (take ((lns * 8 + 4) `div` 5) (f [] (ns ++ replicate (5 - lns) 0))) ++ cs where+        lns = length ns++instance Show Hash where+    showsPrec _ (Hash a b c d) = showAsHex a . showAsHex b . showAsHex c . showAsHex d++showAsHex :: Word32 -> ShowS+showAsHex n = showIt 8 n+   where+    showIt :: Int -> Word32 -> String -> String+    showIt 0 _ r = r+    showIt i x r = case quotRem x 16 of+                       (y, z) -> let c = intToDigit (fromIntegral z)+                                 in c `seq` showIt (i-1) y (c:r)++emptyHash = Hash 0 0 0 0++md5Bytes :: [Word8] -> Hash+md5Bytes bs = unsafePerformIO $ allocaBytes 16 $ \digest -> do+        withArrayLen bs $ \y x -> md5Data (castPtr x) (fromIntegral y) digest+        readDigest digest++md5String :: String -> Hash+md5String ss = md5Bytes (toUTF ss) where+    -- | Convert Unicode characters to UTF-8.+    toUTF :: String -> [Word8]+    toUTF [] = []+    toUTF (x:xs) | ord x<=0x007F = (fromIntegral $ ord x):toUTF xs+                 | ord x<=0x07FF = fromIntegral (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):+                                   fromIntegral (0x80 .|. (ord x .&. 0x3F)):+                                   toUTF xs+                 | otherwise     = fromIntegral (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):+                                   fromIntegral (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):+                                   fromIntegral (0x80 .|. (ord x .&. 0x3F)):+                                   toUTF xs++-- XXX inefficient, don't use it.+md5Handle :: Handle -> IO Hash+md5Handle h = do+    hSeek h AbsoluteSeek 0+    len <- fromIntegral `liftM` hFileSize h+    allocaBytes len $ \ptr -> do+    cnt <- hGetBuf h ptr len+    unless (cnt == len) $ fail "md5File - read returned too few bytes"+    hSeek h AbsoluteSeek 0+    allocaBytes 16 $ \digest -> do+        md5Data ptr (fromIntegral len) digest+        readDigest digest
+ src/Support/MapBinaryInstance.hs view
@@ -0,0 +1,27 @@+module Support.MapBinaryInstance where++import Control.Monad+import Data.Binary+import Data.Map as Map+import Data.Set as Set++putMap :: (Binary k,Ord k,Binary v) => Map.Map k v -> Put+putMap x = do+        put (fromIntegral $ Map.size x :: Word32)+        mapM_ put (Map.toList x)+getMap :: (Binary k,Ord k,Binary v) => Get (Map.Map k v)+getMap = do+        sz <- get :: Get Word32+        ls <- replicateM (fromIntegral sz) get+        return (Map.fromList ls)++putSet :: (Binary a,Ord a) => Set.Set a -> Put+putSet x = do+        put (fromIntegral $ Set.size x :: Word32)+        mapM_ put (Set.toList x)++getSet :: (Binary a,Ord a) => Get (Set.Set a)+getSet = do+        sz <- get :: Get Word32+        ls <- replicateM (fromIntegral sz) get+        return (Set.fromList ls)
+ src/Support/ShowTable.hs view
@@ -0,0 +1,24 @@+module Support.ShowTable where++import List+import Monad+import qualified Data.Map as Map+import qualified Data.Set as Set++class ShowTable a where+    showTablePairs :: a -> [(String,String)]++instance (Show a,Show b) => ShowTable [(a,b)] where+    showTablePairs xs = [ (show x,show y) | (x,y) <- xs ]++instance (Show a,Show b) => ShowTable (Map.Map a b) where+    showTablePairs xs = [ (show x,show y) | (x,y) <- Map.toList xs ]++instance Show a => ShowTable (Set.Set a) where+    showTablePairs xs = [ (show x,"") | x <- Set.toList xs ]+++printTable :: ShowTable a => String -> a -> IO ()+printTable title x = do+    unless (null title) $ putStrLn (title ++ ":")+    mapM_ putStrLn $ sort [ "  " ++ x ++ (if null y then "" else " - " ++ y) | (x,y) <- showTablePairs x]
+ src/Support/TempDir.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE ForeignFunctionInterface,ViewPatterns,RecordWildCards #-}+-- Various routines for dealing with temporary directories and files.+module Support.TempDir(+    getTempDir,+    createTempFile,+    fileInTempDir,+    cleanTempDir,+    setTempDir,+    addAtExit,+    withStackStatus,+    wrapMain+   ) where++import Control.Exception as E+import Control.Monad+import Data.IORef+import Data.Maybe+import System.Directory+import System.Exit+import System.FilePath as FP+import System.IO+import System.IO.Unsafe+import System.IO.Temp+import Text.Printf+import qualified Data.Set as Set+import GenUtil (iocatch)+import Support.CompatMingw32++data TempDir = TempDir {+    tempDirClean   :: Bool,  -- ^ whether to delete the directory afterwords.+    tempDirDump    :: Bool,+    tempDirPath    :: Maybe String,+    tempDirAtExit  :: [IO ()],+    tempDirCleanup :: Set.Set FilePath+    }++putLog :: String -> IO ()+--putLog = putStrLn+putLog _ = return ()++cleanTempDir :: Bool -> IO ()+cleanTempDir b = modifyIORef tdRef $ \x -> x { tempDirClean = b }++setTempDir :: FilePath -> IO ()+setTempDir (FP.normalise -> fp) = do+    TempDir {..} <- readIORef tdRef+    when (isJust $ tempDirPath) $ do+        fail $ printf+          "Cannot set temp directory to '%s'; it is already set to '%s'."+          fp (fromJust tempDirPath)+    putLog $ printf "Setting work directory to '%s'" fp+    createDirectoryIfMissing False fp+    writeIORef tdRef TempDir { tempDirPath = Just fp,  .. }+    cleanTempDir False++getTempDir :: IO FilePath+getTempDir = do+    td <- readIORef tdRef+    case tempDirPath td of+        Just fp -> return fp+        Nothing -> do+            tmpdir <- getTemporaryDirectory+            fp <- createTempDirectory tmpdir "jhc_"+            putLog $ printf "Created work directory '%s'" fp+            writeIORef tdRef td { tempDirPath = Just fp }+            return fp++addAtExit :: IO () -> IO ()+addAtExit action = do+    td <- readIORef tdRef+    writeIORef tdRef td { tempDirAtExit = action:tempDirAtExit td }++createTempFile :: FilePath -> IO (FilePath, Handle)+createTempFile (FP.normalise -> fp) = do+    unless (filePathSafe fp) $+        fail $ "createTempFile: unsafe path " ++ fp+    dir <- getTempDir+    (fp,h) <- openBinaryTempFile dir (if null fp then "temp.tmp" else fp)+    putLog $ printf "Created temporary file '%s'" fp+    addCleanup fp+    return (fp,h)++-- make sure nothing is sneaky about the file path+filePathSafe fp = FP.isRelative fp &&+        ".." `notElem` FP.splitPath fp && not (hasDrive fp)++fileInTempDir :: FilePath -> (FilePath -> IO ()) -> IO FilePath+fileInTempDir (FP.normalise -> fp) action = do+    unless (filePathSafe fp) $+        fail $ "fileinTempDir: unsafe path " ++ fp+    let (FP.normalise -> dpart,_) = FP.splitFileName fp+    tdir <- getTempDir+    let f ("./":ps) cp = f ps cp+        f (".":ps) cp = f ps cp+        f (p:ps) cp = do+            putLog $ printf "Creating directory '%s' '%s' '%s' '%s' '%s'" tdir cp p dpart fp+            createDirectoryIfMissing False (tdir </> cp </> p)+            let cp' = FP.normalise (cp </> p)+            addCleanup cp'+            f ps cp'+        f [] _ = return ()+    f (FP.splitPath dpart) ""+    --unless (null $ FP.normalise dpart) $+    --    fold (FP.splitPath dpart) $ addCleanup+    --    createDirectoryIfMissing True (tdir </> dpart)+    let nfp = FP.normalise (tdir </> fp)+    b <- addCleanup fp+    when b $ action nfp+    return $ noEscapePath nfp++cleanUp :: IO ()+cleanUp = do+    td <- readIORef tdRef+    sequence_ (tempDirAtExit td)+    if not (tempDirClean td) ||+        isNothing (tempDirPath td) then return () else do+    dir <- getTempDir+    forM_ (reverse . Set.toList $ tempDirCleanup td) $ \fp -> do+        putLog $ printf "Removing '%s'" (dir </> fp)+        ignoreError (removeDirectory $ dir </> fp)+        ignoreError (removeFile $ dir </> fp)+    putLog $ printf "Removing '%s'" dir+    ignoreError (removeDirectory dir)++addCleanup :: FilePath -> IO Bool+addCleanup fp = do+    td <- readIORef tdRef+    if fp `Set.member` tempDirCleanup td then return False else do+    writeIORef tdRef td { tempDirCleanup = fp `Set.insert` tempDirCleanup td }+    return True++wrapMain :: IO () -> IO ()+wrapMain main = E.catch (main >> cleanUp) f where+    panic = raiseSigIntCompat+    f (fromException -> Just code) = cleanUp >> exitWith code+    f (fromException -> Just UserInterrupt) = cleanUp >> panic+    f e = do+        ss <- readIORef stackRef+        td <- readIORef tdRef+        case tempDirPath td of+            Just td -> hPutStrLn stderr $+                printf "Exiting abnormally. Work directory is '%s'" td+            _ -> return ()+        unless (null ss) $+            forM_ ("Stack:":ss) (hPutStrLn stderr)+        throwIO e++-------------------+-- support routines+-------------------++ignoreError :: IO () -> IO ()+ignoreError action = iocatch action (\_ -> return ())++{-# NOINLINE tdRef #-}+tdRef :: IORef TempDir+tdRef = unsafePerformIO $ newIORef TempDir {+    tempDirClean   = True,+    tempDirDump    = False,+    tempDirPath    = Nothing,+    tempDirAtExit  = [],+    tempDirCleanup = Set.empty+    }++{-# NOINLINE stackRef #-}+stackRef :: IORef [String]+stackRef = unsafePerformIO $ newIORef []++withStackStatus :: String -> IO a -> IO a+withStackStatus s action = do+    cs <- readIORef stackRef+    writeIORef stackRef (s:cs)+    r <- action+    writeIORef stackRef cs+    return r
+ src/Support/Tickle.hs view
@@ -0,0 +1,15 @@+module Support.Tickle where++import Control.Monad.Identity+import Control.Monad.Writer++class Tickleable a b where+    tickleM :: Monad m => (a -> m a) -> b -> m b+    tickleM_ :: Monad m => (a -> m c) -> b -> m ()+    tickle :: (a -> a) -> b -> b++    tickle f x = runIdentity $ tickleM (return . f) x+    tickleM_ f b = tickleM (\x -> f x >> return x) b >> return ()++tickleCollect :: (Tickleable a b, Monoid o) => (a -> o) -> b -> o+tickleCollect f b = execWriter (tickleM_ (tell . f) b)
+ src/Support/Transform.hs view
@@ -0,0 +1,36 @@+module Support.Transform where++data TransformParms p = TransformParms {+    transformIterate :: Iterate,+    transformDumpProgress :: Bool,+    transformSkipNoStats  :: Bool,+    transformOperation :: p -> IO p,+    transformCategory :: String,   -- ^ general name of transformation+    transformPass :: String,       -- ^ what pass we are in+    transformName :: String        -- ^ name of what we are working on+    }++transformParms :: TransformParms p+transformParms = TransformParms {+    transformIterate = DontIterate,+    transformDumpProgress = False,+    transformSkipNoStats = False,+    transformCategory = "Unknown",+    transformPass = "",+    transformOperation = return,+    transformName = ""+    }++data Iterate = DontIterate | IterateMax !Int | IterateExactly !Int | IterateDone+    deriving(Eq)++doIterate :: Iterate -> Bool -> Bool+doIterate IterateMax {}     True = True+doIterate IterateDone       True = True+doIterate IterateExactly {} _    = True+doIterate _ _ = False++iterateStep :: Iterate -> Iterate+iterateStep (IterateMax n) = IterateMax (n - 1)+iterateStep (IterateExactly n) = IterateExactly (n - 1)+iterateStep x = x
+ src/Support/Tuple.hs view
@@ -0,0 +1,22 @@+module Support.Tuple where++import Data.List(intersperse)++class Tuple a where+    tupleNil :: a+    tupleOne :: a -> a+    tupleMany :: [a] -> a++    tupleNil = tupleMany []+    tupleOne x = x++class FromTuple a where+    fromTuple :: a -> [a]++tuple :: Tuple a => [a] -> a+tuple [] = tupleNil+tuple [x] = tupleOne x+tuple xs = tupleMany xs++instance Tuple String where+    tupleMany xs = "(" ++ concat (intersperse "," xs) ++ ")"
+ src/Support/Unparse.hs view
@@ -0,0 +1,166 @@+module Support.Unparse(Unparse(), Unparsable(..), unparse, unparse', Side(..), atom, atomize, bop, pop, fixitize) where++import Doc.DocLike++data Unparse a = Atom a | Pre a (Unparse a) | Fix (Unparse a) a (Unparse a) !Side !Int | Atomized (Unparse a) | Fixitized  !Side !Int (Unparse a)++data Side = R | L | N+    deriving(Eq)++atom :: a -> Unparse a+atom s = Atom s++atomize :: Unparse a -> Unparse a+atomize (Atomized x) = Atomized x+atomize (Atom a) = Atom a+atomize x = Atomized x++fixitize :: (Side,Int) -> Unparse a -> Unparse a+fixitize (s,i) a = Fixitized s i a++pop :: a -> Unparse a -> Unparse a+pop = Pre++bop :: (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a+bop (s,i) op a b = Fix a op b s i++data Unparsable a = Unparsable {+    unparseGroup :: a -> a,+    unparseCat :: a -> a -> a+    }++data Fix = FAtom | FPre | FFix !Side !Int++unparse :: DocLike a => Unparse a -> a+unparse up = unparse' Unparsable { unparseGroup = parens, unparseCat = (<>) } up++unparse' :: Unparsable a -> Unparse a -> a+unparse' Unparsable { unparseGroup = upg, unparseCat = (<>) } up = fst $ f up where+    f (Atom a) = atom a+    f (Atomized a) = (fst $ f a, FAtom)+    f (Fixitized s i a) = (fst $ f a, FFix s i)+    f (Pre a up) = pop a (f up)+    f (Fix a op b s i) = bop (s,i) op (f a) (f b)++    bop (f1,f2) s (a,FAtom) (b,FAtom)  = (sop s a b, FFix f1 f2)+    bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, FFix f1 f2)+    bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b+    bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))+    bop _ _ _ _ = error "bop"++    pop s (x, FAtom) = ( s <> x, FPre)+    pop s x = pop s $ mkatom x++    atom a = (a,FAtom)+    mkatom (a,FAtom) = (a,FAtom)+    mkatom (a,_) = ( upg a , FAtom)++    sop op a b = a <> (op <> b)++    lts :: Side -> (Side,Int) -> Fix -> Bool+    lts _ _ FAtom = True+    lts _ _ FPre = True+    lts _ (_,n') (FFix  _ n ) | n' /= n = n' < n+    lts R (R,_) (FFix  R _ ) = True+    lts L (L,_) (FFix  L _ ) = True+    lts _ _ _ = False++--lts _ (N,_) (Fix (N,_)) = False++--type Unparse a = (a, Fix)++{-++bop :: Unparsable a => (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a+--bop f "" a b@(_,Pre) = bop f "" a (mkatom b)+bop (f1,f2) s (a,Atom) (b,Atom)  = (sopns s a b, Fix f1 f2)+bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, Fix f1 f2)+bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b+bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))++pop :: Unparsable a => a -> Unparse a -> Unparse a+pop s (x, Atom) = (unparseCat s  x, Pre)+pop s x = pop s $ mkatom x++--sop "" a b = a ++ " " ++ b+sop op a b = unparseSpace a $ unparseSpace op b+--sopns "" a b = a ++ " " ++ b+sopns op a b = unparseCat a $ unparseCat op b++mkatom (a,Atom) = (a,Atom)+mkatom (a,_) = ( unparseGroup a , Atom)+--sop "" a b = a ++ " " ++ b+sop op a b = unparseSpace a $ unparseSpace op b+--sopns "" a b = a ++ " " ++ b+sopns op a b = unparseCat a $ unparseCat op b++mkatom (a,Atom) = (a,Atom)+mkatom (a,_) = ( unparseGroup a , Atom)++instance Unparsable Doc where+    unparseCat  =  (<>)+    unparseSpace  =  (<>)+    unparseGroup  = parens+class Unparsable a where+    unparseGroup :: a -> a+    unparseCat :: a -> a -> a+    unparseSpace :: a -> a -> a+    unparseConcat :: [a] -> a+    unparseConcat = foldl1 unparseCat++instance Unparsable String where+    unparseGroup x = "(" ++ x ++ ")"+    unparseCat x y =  x ++ y+    unparseSpace x y = x ++ " " ++ y+    unparseConcat xs = concat xs++instance Unparsable () where+    unparseGroup _ = ()+    unparseCat _ _ = ()+    unparseSpace _ _ = ()+infixr 9  .+infixr 8  ^, ^^, **+infixl 7  *, /, `quot`, `rem`, `div`, `mod`+infixl 6  +, -++-- The (:) operator is built-in syntax, and cannot legally be given+-- a fixity declaration; but its fixity is given by:+--   infixr 5  :++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||+infixl 1  >>, >>=+infixr 1  =<<+infixr 0  $, $!, `seq`++a + b * c+a + (b * c)++d + a * b + c * d++plus = bop ((L,6)) "+"+minus = bop ((L,6)) "-"+times = bop ((L,7)) "*"+pow = bop ((L,8)) "^"+eq = bop ((N,4)) "=="++a,b,c,d,x,y, abcdr, abcdl, eql :: (String, Fix)++a = text "a"+b = text "b"+c = text "c"+d = text "d"+x = text "x"+y = text "y"++abcdr = foldl1 plus [a,b,c,d]+abcdl = foldr1 plus [a,b,c,d]+eql = foldl1 eq [a,b,c]++z = eq (plus a b) (pow (times b c) abcdl) `eq` eql++g = minus (plus (times (plus a b) (plus b c)) abcdr) abcdl++main = putStrLn $ fst $ foldl1 plus [g,eql, z ]+-}
+ src/Util/BitSet.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE BangPatterns #-}+module Util.BitSet(+    BitSet(),+    EnumBitSet(..),+    toWord,+    fromWord+    ) where+++import Data.List(foldl')+import Data.Bits+import Data.Word+import Data.Monoid+import Util.SetLike+import Util.HasSize++newtype BitSet = BitSet Word+    deriving(Eq,Ord)++instance Monoid BitSet where+    mempty = BitSet 0+    mappend (BitSet a) (BitSet b) = BitSet (a .|. b)+    mconcat ss = foldl' mappend mempty ss++instance Unionize BitSet where+    BitSet a `difference` BitSet b = BitSet (a .&. complement b)+    BitSet a `intersection` BitSet b = BitSet (a .&. b)++type instance  Elem BitSet = Int++instance Collection BitSet where+--    type Elem BitSet = Int+    singleton i = BitSet (bit i)+    fromList ts = BitSet (foldl' setBit 0 ts)+    toList (BitSet w) = f w 0 where+        f 0 _ = []+        f w n = if even w then f (w `shiftR` 1) (n + 1) else n:f (w `shiftR` 1) (n + 1)++type instance Key BitSet = Elem BitSet+instance SetLike BitSet where+    keys bs = toList bs+    delete i (BitSet v) = BitSet (clearBit v i)+    member i (BitSet v) = testBit v i+    insert i (BitSet v) = BitSet (v .|. bit i)+    sfilter fn (BitSet w) = f w 0 0 where+        f 0 _ r = BitSet r+        f w n r = if even w || not (fn n) then f w1 n1 r else f w1 n1 (setBit r n) where+            !n1 = n + 1+            !w1 = w `shiftR` 1+    spartition = error "BitSet.spartition: not impl."++instance IsEmpty BitSet where+    isEmpty (BitSet n) = n == 0++instance HasSize BitSet where+    size (BitSet n) = f 0 n where+        f !c 0 = c+        f !c !v = f (c + 1) (v .&. (v - 1))++{-+instance SetLike BitSet where+    BitSet a `difference` BitSet b = BitSet (a .&. complement b)+    BitSet a `intersection` BitSet b = BitSet (a .&. b)+    BitSet a `disjoint` BitSet b  = ((a .&. b) == 0)+    BitSet a `isSubsetOf` BitSet b = (a .|. b) == b+    sempty = BitSet 0+    union (BitSet a) (BitSet b) = BitSet (a .|. b)+    unions ss = foldl' union sempty ss+++instance BuildSet Int BitSet where+    insert i (BitSet v) = BitSet (v .|. bit i)+    singleton i = BitSet (bit i)+    fromList ts = BitSet (foldl' setBit 0 ts)++instance ModifySet Int BitSet where+    delete i (BitSet v) = BitSet (clearBit v i)+    member i (BitSet v) = testBit v i+    toList (BitSet w) = f w 0 where+        f 0 _ = []+        f w n = if even w then f (w `shiftR` 1) (n + 1) else n:f (w `shiftR` 1) (n + 1)+    sfilter fn (BitSet w) = f w 0 0 where+        f 0 _ r = BitSet r+        f w n r = if even w || not (fn n) then f w1 n1 r else f w1 n1 (setBit r n) where+            !n1 = n + 1+            !w1 = w `shiftR` 1+++-}++instance Show BitSet where+    showsPrec n bs = showsPrec n (toList bs)++newtype EnumBitSet a = EBS BitSet+    deriving(Monoid,Unionize,HasSize,Eq,Ord,IsEmpty)++type instance Elem (EnumBitSet a) = a+instance Enum a => Collection (EnumBitSet a) where+    singleton i = EBS $ singleton (fromEnum i)+    fromList ts = EBS $ fromList (map fromEnum ts)+    toList (EBS w) = map toEnum $ toList w++type instance  Key (EnumBitSet a) = Elem (EnumBitSet a)+instance Enum a => SetLike (EnumBitSet a) where+    delete (fromEnum -> i) (EBS v) = EBS $ delete i v+    member (fromEnum -> i) (EBS v) = member i v+    insert (fromEnum -> i) (EBS v) = EBS $ insert i v+    sfilter f (EBS v) = EBS $ sfilter (f . toEnum) v+    keys = error "EnumBitSet.keys: not impl."+    spartition = error "EnumBitSet.spartition: not impl."++{-+instance Enum a => BuildSet a (EnumBitSet a) where+    fromList xs = EnumBitSet $ fromList (map fromEnum xs)+    insert x (EnumBitSet s) = EnumBitSet $ insert (fromEnum x) s+    singleton x = EnumBitSet $ singleton (fromEnum x)++instance Enum a => ModifySet a (EnumBitSet a) where+    toList (EnumBitSet s) = map toEnum $ toList s+    member x (EnumBitSet s) = member (fromEnum x) s+    delete x (EnumBitSet s) = EnumBitSet $ delete (fromEnum x) s+    sfilter fn (EnumBitSet s) = EnumBitSet $ sfilter (fn . toEnum) s+++instance (Enum a,Show a) => Show (EnumBitSet a) where+    showsPrec n bs = showsPrec n (toList bs)++-}++toWord :: BitSet -> Word+toWord (BitSet w) = w++fromWord :: Word -> BitSet+fromWord w = BitSet w+
+ src/Util/BooleanSolver.hs view
@@ -0,0 +1,246 @@+-- straightforward linear time solver for boolean constraints.++module Util.BooleanSolver(+    CA(),+    CV(..),+    fromCA,+    readValue,+    groundConstraints,+    processConstraints,+    C(),+    Result(..),+    mkCA,+    equals,+    implies++    )where++import Monad+import Data.IORef+import Control.Monad.Trans+import Util.UnionFind+import Data.List(intersperse)+import Data.Monoid+import Data.Typeable+import qualified Data.Set as Set+import qualified Data.Map as Map+import Util.UnionFind as UF+import Data.FunctorM++++type Seq x = [x] -> [x]++newtype C v = C (Seq (CL v))+    deriving(Monoid)+++instance Functor C where+    fmap f (C v) = C (map (fmap f) (v []) ++)++data CV v = CFalse | CTrue | CJust v+    deriving(Eq,Ord,Typeable)++++data CL v = CV v `Cimplies` CV v+    deriving(Eq,Ord)++instance (Show l) => Show (C l) where+    showsPrec _ (C xs) = showString "(" . foldr (.) id (intersperse (showString ",") (map shows (xs []))) . showString ")"++instance Functor CL where+    fmap f (x `Cimplies` y) = fmap f x `Cimplies` fmap f y++instance FunctorM CL where+    fmapM f (x `Cimplies` y) = return Cimplies `ap` (fmapM f x) `ap` (fmapM f y)+++instance Functor CV where+    fmap f (CJust x) = CJust (f x)+    fmap _ CTrue = CTrue+    fmap _ CFalse = CFalse++instance FunctorM CV where+    fmapM f (CJust x) = liftM CJust (f x)+    fmapM _ CTrue = return CTrue+    fmapM _ CFalse = return CFalse++++instance Show v => Show (CV v) where+    showsPrec n (CJust v) = showsPrec n v+    showsPrec _ CTrue = showString "T"+    showsPrec _ CFalse = showString "F"++++++instance (Show e) => Show (CL e) where+    showsPrec d (CJust x `Cimplies` CJust y) = showParen (d > 9) $ showsPrec 10 x . showString " -> " . showsPrec 10 y+    showsPrec d (CTrue `Cimplies` CJust y) = showParen (d > 9) $ showsPrec 10 y . showString " := T"+    showsPrec d (CJust x `Cimplies` CFalse) = showParen (d > 9) $ showsPrec 10 x . showString " := F"+    showsPrec d (x `Cimplies` y) = showParen (d > 9) $ showsPrec 10 x . showString " -> " . showsPrec 10 y++++-- basic constraints++implies,equals :: CV v -> CV v -> C v+implies x y = C ((x `Cimplies` y):)+equals x y = (x `implies` y) `mappend` (y `implies` x)+++-- a variable is either set to a value or bounded by other values+data Ri a = Ri (Set.Set (RS a))  (Set.Set (RS a))++type R a = CV (Ri a)++type RS a = (Element (R a) a)++newtype CA v = CA (RS v)++fromCA :: CA v -> v+fromCA (CA e) = fromElement e++readValue :: MonadIO m => CA v -> m (Result (CA v))+readValue (CA v) = liftIO $ do+    v <- find v+    w <- getW v+    case w of+        CTrue -> return ResultJust { resultValue = True }+        CFalse -> return ResultJust { resultValue = False }+        (CJust (Ri x y)) -> do+            x <- findSet x+            y <- findSet y+            return (ResultBounded (CA v) (map CA $ Set.toList x) (map CA $ Set.toList y))++++findSet :: Set.Set (Element a b) -> IO (Set.Set (Element a b))+findSet xs = mapM find (Set.toList xs) >>= return . Set.fromList+++mkCA :: MonadIO m => v -> m (CA v)+mkCA v = do liftM CA $ new (CJust (Ri mempty mempty)) v+++groundConstraints :: (MonadIO m,Ord v) => C v -> m (C (CA v), Map.Map v (CA v))+groundConstraints (C cs) = liftIO $ do+    ref <- newIORef mempty+    let ccs = cs []+        nv v = do+            r <- readIORef ref+            case Map.lookup v r of+                Just v -> return v+                Nothing -> do+                    e <- liftM CA $ new (CJust (Ri mempty mempty)) v+                    writeIORef ref (Map.insert v e r)+                    return e+    v <- fmapM (fmapM nv) ccs+    rr <- readIORef ref+    return (C (v ++),rr)++++processConstraints :: (Show v,MonadIO m)+    => Bool      -- ^ whether to propagate subset/superset info. if you only care about fixed results you don't need to do this. if you care about residual constraints and equivalance classes after solving then you should set this.+    -> C (CA v)  -- ^ the input+    -> m ()+processConstraints propagateSets (C cs) = mapM_ prule (cs []) where+    prule (CFalse `Cimplies` _) = return ()+    prule (_ `Cimplies` CTrue) = return ()+    prule (CTrue `Cimplies` CFalse) = fail "invalid constraint: T -> F"+    prule (CTrue `Cimplies` CJust (CA y)) = find y >>= set Nothing True+    prule (CJust (CA x) `Cimplies` CFalse) = find x >>= set Nothing False+    prule (CJust (CA x) `Cimplies` CJust (CA y)) | x == y = return ()+    prule (CJust (CA x) `Cimplies` CJust (CA y)) = do x <- find x; y <- find y; pimp x y+    pimp' :: (MonadIO m,Show a) => RS a -> RS a -> m ()+    pimp' x y = do x <- find x; y <- find y; pimp x y+    pimp x y | x == y = return ()+    pimp x y = do+        xv <- getW x+        yv <- getW y+        case (xv,yv) of+            (CJust ra,CJust rb) -> liftIO $ implies x y ra rb+            (CFalse,_) -> return ()+            (_,CTrue) -> return ()+            (CTrue,CFalse) -> fail $ "invalid constraint T -> F: " ++ show x ++ " -> " ++ show y+            (CTrue,CJust _) -> set (Just x) True y+            (CJust _,CFalse) -> set (Just y) False x++    set mu b xe = do+        w <- getW xe+        case (w,b) of+            (CTrue,True) -> return ()+            (CFalse,False) -> return ()+            (CJust (Ri _ sh),True) -> do putW xe CTrue; mapM_ (set mu True) (Set.toList sh)+            (CJust (Ri sl _),False) -> do putW xe CFalse; mapM_ (set mu False) (Set.toList sl)+            _ -> fail $ "invalid constrant: " ++ show xe ++ " := " ++ show b+        fmapM_ (union const xe) mu++    implies :: (MonadIO m,Show a) => RS a -> RS a -> Ri a -> Ri a -> m ()+    implies xe ye ra rb = do+        ra@(Ri xl xh) <- findRi xe ra+        rb@(Ri yl yh) <- findRi ye rb+        if xe `Set.member` yh then liftIO $ equals xe ye ra rb else do+        if xe `Set.member` yl then return () else do+        if ye `Set.member` xl then liftIO $ equals xe ye ra rb else do+        if ye `Set.member` xh then return () else do+        putW xe (CJust $ Ri xl (Set.insert ye xh))+        putW ye (CJust $ Ri (Set.insert xe yl) yh)+        when propagateSets $ mapM_ (pimp' xe) (Set.toList yh)+        when propagateSets $ mapM_ (flip pimp' ye) (Set.toList xl)+        return ()+    findRi x (Ri l h) = do+        l <- liftM Set.fromList (mapM find (Set.toList l))+        h <- liftM Set.fromList (mapM find (Set.toList h))+        return (Ri l h)+    equals xe ye (Ri xl xh) (Ri yl yh) = do+        let nl = (xl `mappend` yl)+        let nh = (xh `mappend` yh)+        union (\ _ _ -> CJust (Ri nl nh)) xe ye+        when propagateSets $ do+            Ri nl nh <- findRi xe (Ri nl nh)+            putW xe (CJust $ Ri nl nh)+            let eq = Set.intersection nl nh+            flip mapM_ (Set.toList eq) $ \ne -> do+                ne <- find ne+                CJust ri <- getW ne+                ri <- findRi ne ri+                equals xe ne (Ri nl nh) ri+            return ()+        return () :: IO ()+++++data Result a =+    ResultJust {+        resultValue :: Bool+    }+    | ResultBounded {+        resultRep :: a,+        resultLB ::[a],+        resultUB ::[a]+    }+++instance Functor Result where+    fmap f (ResultBounded x ys zs) = ResultBounded (f x) (map f ys) (map f zs)+    fmap f (ResultJust x) = ResultJust x++instance (Show a) => Show (Result a) where+    showsPrec _ x = (showResult x ++)++showResult (ResultJust l) = show l+showResult rb@ResultBounded {} = sb (resultLB rb) ++ " <= " ++ show (resultRep rb) ++ " <= " ++ sb (resultUB rb)   where+    sb n | null n = "_"+    sb n = show n++++collectVars (Cimplies x y:xs) = x:y:collectVars xs+collectVars [] = []+
+ src/Util/ContextMonad.hs view
@@ -0,0 +1,32 @@+module Util.ContextMonad where++import Control.Monad.Error++class Monad m => ContextMonad m where+    type ContextOf m+    withContext :: ContextOf m -> m a -> m a++instance Error [String] where+    noMsg = []+    strMsg s = [s]++newtype ContextEither a = ContextEither (Either [String] a)+    deriving(Functor)++runContextEither (ContextEither a) = a++instance Monad ContextEither where+    fail s = ContextEither (Left [s])+    ContextEither x >>= y = case x of+        Left ss -> ContextEither (Left ss)+        Right v -> y v+    return x = ContextEither (Right x)++instance ContextMonad ContextEither where+    type ContextOf ContextEither = String+    withContext s (ContextEither (Left ss)) = ContextEither (Left (s:ss))+    withContext _ r = r++runSimpleContextMonad :: ContextEither a -> a+runSimpleContextMonad (ContextEither (Left ss)) = error $ unlines ss+runSimpleContextMonad (ContextEither (Right x)) = x
+ src/Util/ExitCodes.hs view
@@ -0,0 +1,78 @@+module Util.ExitCodes where++import System.Exit++-- The command was used incorrectly, e.g., with+-- the wrong number of arguments, a bad flag, a bad+-- syntax in a parameter, or whatever.+exitCodeUsage = ExitFailure 64++-- EX_DATAERR -- The input data was incorrect in some way.+-- 	This should only be used for user's data & not+-- 	system files.+exitCodeDataError = ExitFailure 65++-- EX_NOINPUT -- An input file (not a system file) did not+-- 	exist or was not readable.  This could also include+-- 	errors like "No message" to a mailer (if it cared+-- 	to catch it).+exitCodeNoInput = ExitFailure 66++-- EX_NOUSER -- The user specified did not exist.  This might+-- 	be used for mail addresses or remote logins.+exitCodeNoUser = ExitFailure 67++-- EX_NOHOST -- The host specified did not exist.  This is used+-- 	in mail addresses or network requests.+exitCodeNoHost = ExitFailure 68++-- EX_UNAVAILABLE -- A service is unavailable.  This can occur+-- 	if a support program or file does not exist.  This+-- 	can also be used as a catchall message when something+-- 	you wanted to do doesn't work, but you don't know+-- 	why.+exitCodeUnavailable = ExitFailure 69++-- EX_SOFTWARE -- An internal software error has been detected.+-- 	This should be limited to non-operating system related+-- 	errors as possible.+exitCodeSoftware = ExitFailure 70++-- EX_OSERR -- An operating system error has been detected.+-- 	This is intended to be used for such things as "cannot+-- 	fork", "cannot create pipe", or the like.  It includes+-- 	things like getuid returning a user that does not+-- 	exist in the passwd file.+exitCodeOSError = ExitFailure 71++-- EX_OSFILE -- Some system file (e.g., /etc/passwd, /etc/utmp,+-- 	etc.) does not exist, cannot be opened, or has some+-- 	sort of error (e.g., syntax error).+exitCodeOSFile = ExitFailure 72++-- EX_CANTCREAT -- A (user specified) output file cannot be+-- 	created.+exitCodeCantCreate = ExitFailure 73++-- EX_IOERR -- An error occurred while doing I/O on some file.+exitCodeIOErr = ExitFailure 74++-- EX_TEMPFAIL -- temporary failure, indicating something that+-- 	is not really an error.  In sendmail, this means+-- 	that a mailer (e.g.) could not create a connection,+-- 	and the request should be reattempted later.+exitCodeTempFailure = ExitFailure 75++-- EX_PROTOCOL -- the remote system returned something that+-- 	was "not possible" during a protocol exchange.+exitCodeProtocol = ExitFailure 76++-- EX_NOPERM -- You did not have sufficient permission to+-- 	perform the operation.  This is not intended for+-- 	file system problems, which should use NOINPUT or+-- 	CANTCREAT, but rather for higher level permissions.+exitCodeNoPerm = ExitFailure 77++-- configuration error+exitCodeConfig = ExitFailure 78+
+ src/Util/FilterInput.hs view
@@ -0,0 +1,26 @@+module Util.FilterInput (filterInput,readSystem) where++import Control.Monad (when)+import Data.List+import System.IO+import System.Process+import System.Exit+import Text.Printf+import Util.Gen+import qualified Data.ByteString.Lazy.Char8 as LBS+++filterInput :: String -> [String] -> Handle -> IO String+filterInput prog args ifh = do+    input <- hGetContents ifh+    (rExit, rStdout, _) <- readProcessWithExitCode prog args input+    length rStdout `seq` when (rExit /= ExitSuccess) $+      putErrDie (prog ++ " exited abnormally")+    return rStdout++readSystem :: String -> [String] -> IO LBS.ByteString+readSystem prog args = do+    (rExit, rStdout, _) <- readProcessWithExitCode prog args ""+    when (rExit /= ExitSuccess) $+      putErrDie (printf "'%s' exited abnormally (%s)" (intercalate " " (prog:args)) (show rExit))+    return $ LBS.pack rStdout
+ src/Util/GMap.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS -XTypeFamilies #-}+module Util.GMap where++import Data.Monoid+import Util.HasSize+import Util.SetLike+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Set as Set+++data family GMap k :: * -> *+data family GSet k :: *++newtype instance GMap Int v = GMapInt (IM.IntMap v)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike)+newtype instance GSet Int = GSetInt IS.IntSet+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike)++instance Functor (GMap Int) where+    fmap f (GMapInt v) = GMapInt $ fmap f v++type instance Elem (GMap k v) = (k,v)+type instance Key (GMap k v) = k+type instance Value (GMap k v) = v+type instance Elem (GSet k) = k+type instance Key (GSet k) = k++newtype instance GSet Char = GSetChar (EnumSet Char)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike)+newtype instance GMap Char v = GMapChar (EnumMap Char v)+    deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike)++--newtype instance GSet (a,b) = GSetTup2 (GMap a (GSet b))++gsetToSet :: (Collection (GSet a), Ord a) => GSet a -> Set.Set a+gsetToSet gs = Set.fromDistinctAscList (toList gs)++class GMapSet k where+    toSet :: GMap k v -> GSet k+    toMap :: (k -> v) -> GSet k -> GMap k v++instance GMapSet Int where+    toSet (GMapInt im) = GSetInt (IM.keysSet im)+    toMap f (GSetInt is) = GMapInt $ IM.fromDistinctAscList [ (x,f x) | x <- IS.toAscList is]
+ src/Util/Gen.hs view
@@ -0,0 +1,48 @@++-- | similar to GenUtil but can rely on non-haskell 98 features+module Util.Gen(module Util.Gen, module GenUtil, intercalate) where++import Control.Monad.Writer+import Data.List+import Data.Maybe+import System.Directory+import Text.ParserCombinators.ReadP++import GenUtil hiding(replicateM, intercalate)++mconcatMap f xs = mconcat (map f xs)+mintercalate x xs = mconcat (intersperse x xs)++mconcatMapM f xs = mapM f xs >>= return . mconcat++runReadP :: Monad m => ReadP a -> String -> m a+runReadP rp s = case [ x | (x,t) <- readP_to_S rp s, ("","") <- lex t] of+    [x] -> return x+    []  -> fail "runReadP: no parse"+    _   -> fail "runReadP: ambiguous parse"++runEither :: String -> Either String a -> a+runEither msg (Left fm) = error $ msg ++ " - " ++ fm+runEither _ (Right a) = a++travCollect :: Monoid w => ((a -> Writer w a) -> a -> Writer w a) -> (a -> w) -> a -> w+travCollect fn col x = execWriter (f x) where+    f x = tell (col x) >> fn f x++forMn_ xs = forM_ (zip xs [0 :: Int .. ])+forMn xs = forM (zip xs [0 :: Int .. ])++shortenPath :: String -> IO String+shortenPath x@('/':_) = do+    cd <- getCurrentDirectory+    pwd <- lookupEnv "PWD"+    h <- lookupEnv "HOME"+    let f d = do+            d <- d+            '/':rest <- getPrefix d x+            return rest+    return $ fromJust $ f (return cd) `mplus` f pwd `mplus` liftM ("~/" ++) (f h) `mplus` return x+shortenPath x = return x++maybeDo :: Monad m => Maybe (m a) -> (m ())+maybeDo x = maybe (return ()) (>> return ()) x
+ src/Util/Graph.hs view
@@ -0,0 +1,228 @@+-- | Data.Graph is sorely lacking in several ways, This just tries to fill in+-- some holes and provide a more convinient interface+{-# LANGUAGE DoRec #-}++module Util.Graph(+    Graph(),+    fromGraph,+    newGraph,+    newGraph',+    newGraphReachable,+    reachableFrom,+    Util.Graph.reachable,+    fromScc,+    findLoopBreakers,+    sccGroups,+    Util.Graph.scc,+    sccForest,+    Util.Graph.dff,+    Util.Graph.components,+    Util.Graph.topSort,+    cyclicNodes,+    toDag,+    restitchGraph,+    mapGraph,+    transitiveClosure,+    transitiveReduction+    ) where++import Control.Monad+import Control.Monad.ST+import Data.Array.IArray+import Data.Array.ST hiding(unsafeFreeze)+import Data.Array.Unsafe (unsafeFreeze)+import Data.Graph hiding(Graph)+import Data.Maybe+import GenUtil+import Data.List(sort,sortBy,group,delete)+import qualified Data.Graph as G+import qualified Data.Map as Map+++data Graph n = Graph G.Graph (Table n)+++instance Show n => Show (Graph n) where+    showsPrec n g = showsPrec n (Util.Graph.scc g)++fromGraph :: Graph n -> [(n,[n])]+fromGraph (Graph g lv) = [ (lv!v,map (lv!) vs) | (v,vs) <- assocs g ]++newGraph :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Graph n)+newGraph ns a b = snd $ newGraph' ns a b++newGraphReachable :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> ([k] -> [n],Graph n)+newGraphReachable ns fn fd = (rable,ng) where+    (vmap,ng) = newGraph' ns fn fd+    rable ks = Util.Graph.reachable ng [ v | Just v <- map (flip Map.lookup vmap) ks ]++reachableFrom :: Ord k => (n -> k) -> (n -> [k]) -> [n] -> [k] -> [n]+reachableFrom fn fd ns  = fst $ newGraphReachable ns fn fd++-- | Build a graph from a list of nodes uniquely identified by keys,+-- with a list of keys of nodes this node should have edges to.+-- The out-list may contain keys that don't correspond to+-- nodes of the graph; they are ignored.+newGraph' :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Map.Map k Vertex,Graph n)+newGraph' ns fn fd = (kmap,Graph graph nr) where+    nr = listArray bounds0 ns+    max_v      	    = length ns - 1+    bounds0         = (0,max_v) :: (Vertex, Vertex)+    kmap = Map.fromList [ (fn n,i) | (i,n) <- zip [0 ..] ns ]+    graph	    = listArray bounds0 [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- ns]++fromScc (Left n) = [n]+fromScc (Right n) = n++-- | determine a set of loopbreakers subject to a fitness function+-- loopbreakers have a minimum of their  incoming edges ignored.+findLoopBreakers+    :: (n -> Int)  -- ^ fitness function, greater numbers mean more likely to be a loopbreaker+    -> (n -> Bool) -- ^ whether a node is suitable at all for a choice as loopbreaker+    -> Graph n     -- ^ the graph+    ->  ([n],[n])  -- ^ (loop breakers,dependency ordered nodes after loopbreaking)+findLoopBreakers func ex (Graph g ln) = ans where+    scc = G.scc g+    ans = f g scc [] [] where+        f g (Node v []:sccs) fs lb+            | v `elem` g ! v = let ng = (fmap (delete v) g) in  f ng (G.scc ng) [] (v:lb)+            | otherwise = f g sccs (v:fs) lb++        f g (n:_) fs lb = f ng (G.scc ng) [] (mv:lb) where+            mv = case  sortBy (\ a b -> compare (snd b) (snd a)) [ (v,func (ln!v)) | v <- ns, ex (ln!v) ] of+                ((mv,_):_) -> mv+                [] -> error "findLoopBreakers: no valid loopbreakers"+            ns = dec n []+            ng = fmap (delete mv) g++        f _ [] xs lb = (map ((ln!) . head) (group $ sort lb),reverse $ map (ln!) xs)+    dec (Node v ts) vs = v:foldr dec vs ts+++reachable :: Graph n -> [Vertex] -> [n]+reachable (Graph g ln) vs = map (ln!) $ snub $  concatMap (G.reachable g) vs++sccGroups :: Graph n -> [[n]]+sccGroups g = map fromScc (Util.Graph.scc g)++scc :: Graph n -> [Either n [n]]+scc (Graph g ln) = map decode forest where+    forest = G.scc g+    decode (Node v [])+        | v `elem` g ! v = Right [ln!v]+        | otherwise = Left (ln!v)+    decode other = Right (dec other [])+    dec (Node v ts) vs = ln!v:foldr dec vs ts++sccForest :: Graph n -> Forest n+sccForest (Graph g ln) = map (fmap (ln!)) forest where+    forest = G.scc g++dff :: Graph n -> Forest n+dff (Graph g ln) = map (fmap (ln!)) forest where+    forest = G.dff g++components :: Graph n -> [[n]]+components (Graph g ln) = map decode forest where+    forest = G.components g+    decode n = dec n []+    dec (Node v ts) vs = ln!v:foldr dec vs ts+++topSort :: Graph n -> [n]+topSort (Graph g ln) = map (ln!) $ G.topSort g++cyclicNodes :: Graph n -> [n]+cyclicNodes g = concat [ xs | Right xs <- Util.Graph.scc g]++toDag :: Graph n -> Graph [n]+toDag (Graph g lv) = Graph g' ns' where+    ns' = listArray (0,max_v) [ map (lv!) ns |  ns <- nss ]+    g' = listArray (0,max_v) [ snub [ v | n <- ns, v <- g!n ] | ns <- nss ]+    max_v = length nss - 1+    nss = map (flip f []) (G.scc g) where+        f (Node v ts) rs = v:foldr f rs ts++type AdjacencyMatrix s  = STArray s (Vertex,Vertex) Bool+type IAdjacencyMatrix  = Array (Vertex,Vertex) Bool++transitiveClosureAM :: AdjacencyMatrix s -> ST s ()+transitiveClosureAM arr = do+    bnds@(_,(max_v,_)) <- getBounds arr+    forM_ [0 .. max_v] $ \k -> do+        forM_ (range bnds) $ \ (i,j) -> do+                dij <- readArray arr (i,j)+                dik <- readArray arr (i,k)+                dkj <- readArray arr (k,j)+                writeArray arr (i,j) (dij || (dik && dkj))++++transitiveReductionAM :: AdjacencyMatrix s -> ST s ()+transitiveReductionAM arr = do+    bnds@(_,(max_v,_)) <- getBounds arr+    transitiveClosureAM arr+    (farr :: IAdjacencyMatrix) <- freeze arr+    forM_ [0 .. max_v] $ \k -> do+        forM_ (range bnds) $ \ (i,j) -> do+            if farr!(k,i) && farr!(i,j) then+                writeArray arr (k,j) False+             else return ()++toAdjacencyMatrix :: G.Graph -> ST s (AdjacencyMatrix s)+toAdjacencyMatrix g = do+    let (0,max_v) = bounds g+    arr <- newArray ((0,0),(max_v,max_v)) False :: ST s (STArray s (Vertex,Vertex) Bool)+    sequence_ [ writeArray arr (v,u) True | (v,vs) <- assocs g, u <- vs ]+    return arr++fromAdjacencyMatrix :: AdjacencyMatrix s -> ST s G.Graph+fromAdjacencyMatrix arr = do+    bnds@(_,(max_v,_)) <- getBounds arr+    rs <- getAssocs arr+    let rs' = [ x | (x,True) <- rs ]+    return (listArray (0,max_v) [ [ v | (n',v) <- rs', n == n' ] | n <- [ 0 .. max_v] ])++transitiveClosure :: Graph n -> Graph n+transitiveClosure (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where+    tc g = do+        a <- toAdjacencyMatrix g+        transitiveClosureAM a+        fromAdjacencyMatrix a++transitiveReduction :: Graph n -> Graph n+transitiveReduction (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where+    tc g = do+        a <- toAdjacencyMatrix g+        transitiveReductionAM a+        fromAdjacencyMatrix a+++instance Functor Graph where+    fmap f (Graph g n) = Graph g (fmap f n)++--mapT    :: (Vertex -> a -> b) -> Table a -> Table b+--mapT f t = listArray (bounds t) [ (f v (t!v)) | v <- indices t ]++restitchGraph :: Ord k => (n -> k) -> (n -> [k]) -> Graph n -> Graph n+restitchGraph fn fd (Graph g nr) = Graph g' nr where+    kmap = Map.fromList [ (fn n,i) | (i,n) <- assocs nr ]+    g'	 = listArray (bounds g) [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- elems nr]++mapGraph :: forall a b . (a -> [b] -> b) -> Graph a -> Graph b+mapGraph f (Graph gr nr) = runST $ do+    mnr <- thaw nr  :: ST s (STArray s Vertex a)+    mnr <- mapArray Left mnr+    let g i = readArray mnr i >>= \v -> case v of+            Right m -> return m+            Left l -> mdo+                writeArray mnr i (Right r)+                rs <- mapM g (gr!i)+                let r = f l rs+                return r+    mapM_ g (range $ bounds nr)+    mnr <- mapArray fromRight mnr+    mnr <- unsafeFreeze mnr+    return (Graph gr mnr)++
+ src/Util/Graphviz.hs view
@@ -0,0 +1,85 @@+-- | Simple graphviz output.+module Util.Graphviz(+    Orient(..),+    graphviz, graphviz'+) where++import Data.Graph.Inductive.Graph+import Data.List(intersperse)++data Orient = Portrait | Landscape deriving (Eq, Show)++{-+o2s :: Orient -> String+o2s Portrait = "\trotate = \"0\"\n"+o2s Landscape = "\trotate = \"90\"\n"++i2d :: Int -> Double+i2d = fromInteger . toInteger+-}+++-- | Format a graph for graphviz with reasonable defaults: title of \"fgl\",+-- 8.5x11 pages, one page, landscape orientation+graphviz' :: Graph g => g a b -> [(String,String)] -> (a -> [(String,String)]) -> (b -> [(String,String)]) -> String+graphviz' g headers fnode fedge = graphviz g "fgl" headers fnode fedge  (8.5,11.0) (1,1) Landscape++sq :: String -> String+sq ('"':s) | last s == '"'  = init s+	   | otherwise	    = s+sq ('\'':s) | last s == '\''	= init s+	    | otherwise		= s+sq s = s+++sl :: [(String,String)] -> String+sl [] = []+sl a = " [" ++ foldr ($) "]" (intersperse (',':) (map showEq a)) where++showEq :: (String,String) -> String -> String+showEq (x,y) = ((x ++ " = " ++  (show y)) ++)++++graphviz :: Graph g =>    g a b   -- ^ The graph to format+			  -> String  -- ^ The title of the graph+                          -> [(String,String)]+                          -> (a -> [(String,String)])+                          -> (b -> [(String,String)])+			  -> (Double, Double)	-- ^ The size+			  -- of the page+			  -> (Int, Int)	-- ^ The width and+			  -- height of the page+			  -- grid+			  -> Orient  -- ^ The orientation of+			  -- the graph.+			  -> String+++graphviz g t headers fnode fedge (w, h) p@(pw', ph') o =+    let n = labNodes g+	e = labEdges g+	ns = concatMap sn n+	es = concatMap se e+	--sz w' h' = if o == Portrait then show w'++","++show h' else show h'++","++show w'+	--ps = show w++","++show h+	--(pw, ph) = if o == Portrait then p else (ph', pw')+	--gs = show ((w*(i2d pw))-m)++","++show ((h*(i2d ph))-m)+	--gs = sz (w*(i2d pw)) (h*(i2d ph))+    in "digraph "++sq t++" {\n"+--	    ++"\tmargin = \"0\"\n"+--	    ++"\tpage = \""++ps++"\"\n"+--	    ++"\tsize = \""++gs++"\"\n"+            ++ concatMap (\x -> showEq x "\n") headers+--	    ++ o2s o+--	    ++"\tratio = \"fill\"\n"+	    ++ns+	    ++es+	++"}"+    where sn (n, a) | sa == ""	= ""+		    | otherwise	= '\t':(show n ++ sa ++ "\n")+	    where sa = sl (fnode a)+	  se (n1, n2, b) = '\t':(show n1 ++ " -> " ++ show n2 ++ sl (fedge b) ++ "\n")+++
+ src/Util/HasSize.hs view
@@ -0,0 +1,96 @@+module Util.HasSize where++-- this point of this module is not only to share the 'size' syntax, but to+-- provide optimally lazy versions of size comparasin functions when dealing+-- with lazy structures. This is especially useful when having to compare the+-- size of possibly long lists.++-- it is up to each instance to decide what 'size' means++import qualified Data.Map(Map,size,null)+import qualified Data.Set(Set,size,null)+import qualified Data.IntMap(IntMap,size,null)+import qualified Data.IntSet(IntSet,size,null)+++class IsEmpty a where+    isEmpty :: a -> Bool++class HasSize a where+    size :: a -> Int+    sizeEQ :: Int -> a -> Bool+    sizeGT :: Int -> a -> Bool+    sizeLT :: Int -> a -> Bool+    sizeGTE :: Int -> a -> Bool+    sizeLTE :: Int -> a -> Bool+    sizeEQ s x = size x == s+    sizeGT s x = size x > s+    sizeLT s x = size x < s+    sizeGTE s x = not $ sizeLT s x+    sizeLTE s x = not $ sizeGT s x++genSize :: (Integral b,HasSize a) => a -> b+genSize = fromIntegral . Util.HasSize.size++instance HasSize [x] where+    size = length+    sizeEQ n _ | n < 0 = False+    sizeEQ n xs = f n xs where+        f 0 [] = True+        f _ [] = False+        f 0 _ = False+        f n (_:xs) = sizeEQ (n - 1) xs+    sizeGT n _ | n < 0 = True+    sizeGT n xs = f n xs where+        f 0 (_:_) = True+        f n [] = False+        f n (_:xs) = f (n - 1) xs+    sizeLT n _ | n <= 0 = False+    sizeLT n xs = f n xs where+        f 0 _ = False+        f _ [] = True+        f n (_:xs) = f (n - 1) xs+++instance HasSize (Data.Map.Map a b) where+    size = Data.Map.size+instance HasSize (Data.Set.Set a) where+    size = Data.Set.size+instance HasSize (Data.IntMap.IntMap v) where+    size = Data.IntMap.size+instance HasSize Data.IntSet.IntSet where+    size = Data.IntSet.size++instance (HasSize a,HasSize b) => HasSize (Either a b) where+    size (Left x) = size x+    size (Right y) = size y+    sizeEQ s (Left x)  = sizeEQ s x+    sizeEQ s (Right x)  = sizeEQ s x+    sizeLT s (Left x)  = sizeLT s x+    sizeLT s (Right x)  = sizeLT s x+    sizeGT s (Left x)  = sizeGT s x+    sizeGT s (Right x)  = sizeGT s x++instance (HasSize a,HasSize b) => HasSize (a,b) where+    size (x,y) = size x + size y+instance (HasSize a,HasSize b,HasSize c) => HasSize (a,b,c) where+    size (x,y,z) = size x + size y  + size z++instance IsEmpty [x] where+    isEmpty = null++instance IsEmpty (Data.Map.Map a b) where+    isEmpty = Data.Map.null+instance IsEmpty (Data.Set.Set a) where+    isEmpty = Data.Set.null+instance IsEmpty (Data.IntMap.IntMap v) where+    isEmpty = Data.IntMap.null+instance IsEmpty Data.IntSet.IntSet where+    isEmpty = Data.IntSet.null++instance (IsEmpty a,IsEmpty b) => IsEmpty (a,b) where+    isEmpty (x,y) = isEmpty x && isEmpty y+instance (IsEmpty a,IsEmpty b,IsEmpty c) => IsEmpty (a,b,c) where+    isEmpty (x,y,z) = isEmpty x && isEmpty y  && isEmpty z++
+ src/Util/Histogram.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS -XDeriveDataTypeable #-}+module Util.Histogram(+    Histogram,+    singleton,+    insert,+    find,+    toList,+    satisfy,+    satisfyKey,+    Util.Histogram.filter,+    keys,+    elems,+    unions,+    union,+    fromList,+    Util.Histogram.map,+    Util.Histogram.mapM,+    Util.Histogram.mapM_+    ) where++import qualified Data.Map as Map+import Data.Monoid+import Data.Typeable+import qualified Data.List as L++newtype Histogram a = Histogram (Map.Map a Int)+    deriving(Show,Typeable)++instance Ord a => Monoid (Histogram a) where+    mempty = Histogram Map.empty+    mappend (Histogram a) (Histogram b) = Histogram $ Map.unionWith (+) a b++singleton :: a -> Histogram a+singleton a = Histogram (Map.singleton a 1)++insert :: Ord a => a -> Histogram a -> Histogram a+insert a (Histogram m) = Histogram (Map.insertWith (+) a 1 m)++find :: (Ord a) => a -> Histogram a -> Int+find a (Histogram m) = Map.findWithDefault 0 a m++toList :: Histogram a -> [(a, Int)]+toList (Histogram m) = Map.toAscList m++satisfy :: (Int -> Bool) -> Histogram a -> [a]+satisfy f (Histogram m) = [ a | (a,i) <- Map.toAscList m, f i ]++satisfyKey :: (Int -> Bool) -> Histogram a -> [(a,Int)]+satisfyKey f (Histogram m) = [ (a,i) | (a,i) <- Map.toAscList m, f i ]++filter :: Ord a => (a -> Int -> Bool) -> Histogram a -> Histogram a+filter f (Histogram m) = Histogram (Map.filterWithKey f m)++keys :: Histogram a -> [a]+keys (Histogram m) = Map.keys m+elems :: Histogram a -> [Int]+elems (Histogram m) = Map.elems m++map :: Ord b => (a -> b) -> Histogram a -> Histogram b+map f (Histogram m) = Histogram $ Map.fromList [ (f k,i) | (k,i) <- Map.toList m ]++mapM :: (Monad m, Ord b) => (a -> m b) -> Histogram a -> m (Histogram b)+mapM f (Histogram m) = do+        ds <- sequence [ do f k >>= return . flip (,) i  | (k,i) <- Map.toList m ]+        return $ Histogram (Map.fromList ds)++mapM_ :: (Monad m) => (a -> m b) -> Histogram a -> m ()+mapM_ f (Histogram m) = sequence_ [ do f k >>= return . flip (,) i  | (k,i) <- Map.toList m ]++fromList :: Ord a => [a] -> Histogram a+fromList xs = L.foldl' (flip insert) empty xs++empty :: Histogram a+empty = Histogram Map.empty++union :: Ord a => Histogram a -> Histogram a -> Histogram a+union = mappend+unions :: Ord a => [Histogram a] -> Histogram a+unions = mconcat
+ src/Util/Inst.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++-- Useful instances that don't belong anywhere else.+module Util.Inst() where++import Control.Monad.Identity+import Data.Monoid+#if __GLASGOW_HASKELL__ <= 610+import qualified Data.Map as Map+import qualified Data.IntMap as IM+import List+import Data.Traversable+#endif+++instance Monoid (IO ()) where+    mappend a b = a >> b+    mempty = return ()++instance Monoid Bool where+    mempty = False+    mappend a b = a || b+    mconcat = or+++instance Show a => Show (Identity a) where+    show x = show $ runIdentity x+++#if __GLASGOW_HASKELL__ <= 610+instance Traversable IM.IntMap where+    traverse f mp = (IM.fromAscList . Map.toAscList) `fmap`  (traverse f . Map.fromAscList . IM.toAscList $ mp)+#endif
+ src/Util/IntBag.hs view
@@ -0,0 +1,1326 @@+{-# LANGUAGE CPP,NoBangPatterns,MagicHash #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntBag+-- Copyright   :  (c) Daan Leijen 2002+-- Copyright   :  (c) John Meacham 2007+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- An efficient implementation of maps from integer keys to integers.+--+-- modified from Data.IntMap+--++module Util.IntBag  (+            -- * Map type+              IntBag, Key          -- instance Eq,Show++            -- * Operators+            , (!)++            --, (\\)++            -- * Query+            , null+            , size+--            , member+--            , notMember+--	    , lookup+--            , findWithDefault++            -- * Construction+            , empty+            , singleton+            , msingleton++            -- ** Insertion+            , insert+--            , insertWith, insertWithKey, insertLookupWithKey++            -- ** Delete\/Update+            , delete+--            , adjust+--            , adjustWithKey+--            , update+--            , updateWithKey+--            , updateLookupWithKey+--            , alter+--+            -- * Combine++            -- ** Union+            , union+--            , unionWith+--            , unionWithKey+--            , unions+--            , unionsWith++            -- ** Difference+--            , difference+--            , differenceWith+--            , differenceWithKey+--+--            -- ** Intersection+--            , intersection+--            , intersectionWith+--            , intersectionWithKey++            -- * Traversal+            -- ** Map+--            , map+--            , mapWithKey+--            , mapAccum+--            , mapAccumWithKey+--+            -- ** Fold+            , fold+            , foldWithKey++            -- * Conversion+--            , elems+--            , keys+--	    , keysSet+            , assocs++            -- ** Lists+            , toList+            , fromList+--            , fromListWith+--            , fromListWithKey++            -- ** Ordered lists+            , toAscList+--            , fromAscList+--            , fromAscListWith+--            , fromAscListWithKey+--            , fromDistinctAscList++            -- * Filter+--            , filter+--            , filterWithKey+--            , partition+--            , partitionWithKey+--+--            , mapMaybe+--            , mapMaybeWithKey+--            , mapEither+--            , mapEitherWithKey+--+--            , split+--            , splitLookup+--+            -- * Submap+--            , isSubmapOf, isSubmapOfBy+--            , isProperSubmapOf, isProperSubmapOfBy++            -- * Debugging+--            , showTree+--            , showTreeWith+            ) where+++import Prelude hiding (lookup,map,filter,foldr,foldl,null)+import Data.Bits+import Data.Monoid (Monoid(..))++++#if __GLASGOW_HASKELL__ >= 503+import GHC.Word+import GHC.Exts (  Int(..), shiftRL# )+#elif __GLASGOW_HASKELL__+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#else+import Data.Word+#endif++--infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++natFromInt :: Key -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Key+intFromNat w = fromIntegral w++shiftRL :: Nat -> Key -> Nat+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+  GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i)+  = W# (shiftRL# x i)+#else+shiftRL x i   = shiftR x i+#endif++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | /O(min(n,W))/. Find the value at a key.+-- Calls 'error' when the element can not be found.++(!) :: IntBag-> Key -> Int+m ! k    = find' k m++-- | /O(n+m)/. See 'difference'.+--(\\) :: IntBag -> IntBag -> IntBag+--m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+-- | A map of integers to values @a@.+data IntBag = Nil+              | Tip {-# UNPACK #-} !Key {-# UNPACK #-} !Int+              | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntBag !IntBag++type Prefix = Int+type Mask   = Int+type Key    = Int++instance Monoid IntBag where+    mempty  = empty+    mappend = union+    mconcat = unions++++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+null :: IntBag -> Bool+null Nil   = True+null other = False++-- | /O(n)/. Number of elements in the map.+size :: IntBag -> Int+size t+  = case t of+      Bin p m l r -> size l + size r+      Tip k x -> x+      Nil     -> 0++-- | /O(min(n,W))/. Is the key a member of the map?+--member :: Key -> IntBag -> Bool+--member k m+--  = case lookup k m of+--      Nothing -> False+--      Just x  -> True++-- | /O(log n)/. Is the key not a member of the map?+--notMember :: Key -> IntBag -> Bool+--notMember k m = not $ member k m++-- | /O(min(n,W))/. Lookup the value at a key in the map.+--lookup :: (Monad m) => Key -> IntBag -> m Int+--lookup k t = case lookup' k t of+--    Just x -> return x+--    Nothing -> fail "Data.IntBag.lookup: Key not found"+--+--lookup' :: Key -> IntBag -> Maybe Int+--lookup' k t+--  = let nk = natFromInt k  in seq nk (lookupN nk t)+--+--+lookupN :: Nat -> IntBag -> Int+lookupN k t+  = case t of+      Bin p m l r+        | zeroN k (natFromInt m) -> lookupN k l+        | otherwise              -> lookupN k r+      Tip kx x+        | (k == natFromInt kx)  -> x+        | otherwise             -> 0+      Nil -> 0++find' :: Key -> IntBag -> Int+find' k m  = lookupN (natFromInt k) m+++-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--findWithDefault :: Int -> Key -> IntBag -> Int+--findWithDefault def k m+--  = case lookup k m of+--      Nothing -> def+--      Just x  -> x++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+empty :: IntBag+empty = Nil++-- | /O(1)/. A map of one element.+singleton :: Key -> IntBag+singleton k = Tip k 1++msingleton :: Key -> Int -> IntBag+msingleton k x | x > 0 = Tip k x+               | otherwise = Nil++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- added to the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: Key -> Int -> IntBag -> IntBag+insert k x t | k `seq` x < 0 = delete k (negate x) t+insert _ 0 t = t+insert k x t = f t where+    f t = case t of+      Bin p m l r+        | nomatch k p m -> join k (Tip k x) p t+        | zero k m      -> Bin p m (f l) r+        | otherwise     -> Bin p m l (f r)+      Tip ky y+        | k==ky         -> Tip k (x + y)+        | otherwise     -> join k (Tip k x) ky t+      Nil -> Tip k x++++{--------------------------------------------------------------------+  Deletion+  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: Key -> Int -> IntBag -> IntBag+delete k 0 t | k `seq` True = t+delete k x t | x < 0 = insert k (negate x) t+delete k x t = f t where+    f t = case t of+      Bin p m l r+        | nomatch k p m -> t+        | zero k m      -> bin p m (f l) r+        | otherwise     -> bin p m l (f r)+      Tip ky y+        | k==ky         -> if y < x then Nil else Tip ky (y - x)+        | otherwise     -> t+      Nil -> Nil++---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+---- a member of the map, the original map is returned.+--adjust ::  (a -> a) -> Key -> IntBag -> IntBag+--adjust f k m+--  = adjustWithKey (\k x -> f x) k m+--+---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+---- a member of the map, the original map is returned.+--adjustWithKey ::  (Key -> a -> a) -> Key -> IntBag -> IntBag+--adjustWithKey f k m+--  = updateWithKey (\k x -> Just (f k x)) k m+--+---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+---- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+---- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--update ::  (a -> Maybe a) -> Key -> IntBag -> IntBag+--update f k m+--  = updateWithKey (\k x -> f x) k m+--+---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+---- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+---- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntBag -> IntBag+--updateWithKey f k t+--  = case t of+--      Bin p m l r+--        | nomatch k p m -> t+--        | zero k m      -> bin p m (updateWithKey f k l) r+--        | otherwise     -> bin p m l (updateWithKey f k r)+--      Tip ky y+--        | k==ky         -> case (f k y) of+--                             Just y' -> Tip ky y'+--                             Nothing -> Nil+--        | otherwise     -> t+--      Nil -> Nil+--+---- | /O(min(n,W))/. Lookup and update.+--updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntBag -> (Maybe a,IntBag)+--updateLookupWithKey f k t+--  = case t of+--      Bin p m l r+--        | nomatch k p m -> (Nothing,t)+--        | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)+--        | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')+--      Tip ky y+--        | k==ky         -> case (f k y) of+--                             Just y' -> (Just y,Tip ky y')+--                             Nothing -> (Just y,Nil)+--        | otherwise     -> (Nothing,t)+--      Nil -> (Nothing,Nil)+--+--+--+---- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+---- 'alter' can be used to insert, delete, or update a value in a 'Map'.+---- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@+--alter f k t+--  = case t of+--      Bin p m l r+--        | nomatch k p m -> case f Nothing of+--                             Nothing -> t+--                             Just x -> join k (Tip k x) p t+--        | zero k m      -> bin p m (alter f k l) r+--        | otherwise     -> bin p m l (alter f k r)+--      Tip ky y+--        | k==ky         -> case f (Just y) of+--                             Just x -> Tip ky x+--                             Nothing -> Nil+--        | otherwise     -> case f Nothing of+--                             Just x -> join k (Tip k x) ky t+--                             Nothing -> Tip ky y+--      Nil               -> case f Nothing of+--                             Just x -> Tip k x+--                             Nothing -> Nil+--++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+unions :: [IntBag] -> IntBag+unions xs+  = foldlStrict union empty xs++-- | The union of a list of maps, with a combining operation+--unionsWith :: (Int->Int->Int) -> [IntBag] -> IntBag+--unionsWith f ts+--  = foldlStrict (unionWith f) empty ts++-- | /O(n+m)/. The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+union :: IntBag -> IntBag -> IntBag+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (union t1 r2)++union (Tip k x) t = insert k x t+union t (Tip k x) = insert k x t+--union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias+union Nil t       = t+union t Nil       = t++-- | /O(n+m)/. The union with a combining function.+--unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+--unionWith f m1 m2+--  = unionWithKey (\k x y -> f x y) m1 m2+--+---- | /O(n+m)/. The union with a combining function.+--unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+--unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = union1+--  | shorter m2 m1  = union2+--  | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)+--  | otherwise      = join p1 t1 p2 t2+--  where+--    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+--            | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1+--            | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)+--+--    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+--            | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2+--            | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)+--+--unionWithKey f (Tip k x) t = insertWithKey f k x t+--unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias+--unionWithKey f Nil t  = t+--unionWithKey f t Nil  = t++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two maps (based on keys).+--difference :: IntMap a -> IntMap b -> IntMap a+--difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = difference1+--  | shorter m2 m1  = difference2+--  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)+--  | otherwise      = t1+--  where+--    difference1 | nomatch p2 p1 m1  = t1+--                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1+--                | otherwise         = bin p1 m1 l1 (difference r1 t2)+--+--    difference2 | nomatch p1 p2 m2  = t1+--                | zero p1 m2        = difference t1 l2+--                | otherwise         = difference t1 r2+--+--difference t1@(Tip k x) t2+--  | member k t2  = Nil+--  | otherwise    = t1+--+--difference Nil t       = Nil+--difference t (Tip k x) = delete k t+--difference t Nil       = t+--+---- | /O(n+m)/. Difference with a combining function.+--differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+--differenceWith f m1 m2+--  = differenceWithKey (\k x y -> f x y) m1 m2+--+---- | /O(n+m)/. Difference with a combining function. When two equal keys are+---- encountered, the combining function is applied to the key and both values.+---- If it returns 'Nothing', the element is discarded (proper set difference).+---- If it returns (@'Just' y@), the element is updated with a new value @y@.+--differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+--differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = difference1+--  | shorter m2 m1  = difference2+--  | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)+--  | otherwise      = t1+--  where+--    difference1 | nomatch p2 p1 m1  = t1+--                | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1+--                | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)+--+--    difference2 | nomatch p1 p2 m2  = t1+--                | zero p1 m2        = differenceWithKey f t1 l2+--                | otherwise         = differenceWithKey f t1 r2+--+--differenceWithKey f t1@(Tip k x) t2+--  = case lookup k t2 of+--      Just y  -> case f k x y of+--                   Just y' -> Tip k y'+--                   Nothing -> Nil+--      Nothing -> t1+--+--differenceWithKey f Nil t       = Nil+--differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t+--differenceWithKey f t Nil       = t+--++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+---- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).+--intersection :: IntBag -> IntBag -> IntBag+--intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = intersection1+--  | shorter m2 m1  = intersection2+--  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+--  | otherwise      = Nil+--  where+--    intersection1 | nomatch p2 p1 m1  = Nil+--                  | zero p2 m1        = intersection l1 t2+--                  | otherwise         = intersection r1 t2+--+--    intersection2 | nomatch p1 p2 m2  = Nil+--                  | zero p1 m2        = intersection t1 l2+--                  | otherwise         = intersection t1 r2+--+--intersection t1@(Tip k x) t2+--  | member k t2  = t1+--  | otherwise    = Nil+--intersection t (Tip k x)+--  = case lookup k t of+--      Just y  -> Tip k y+--      Nothing -> Nil+--intersection Nil t = Nil+--intersection t Nil = Nil+--+---- | /O(n+m)/. The intersection with a combining function.+--intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a+--intersectionWith f m1 m2+--  = intersectionWithKey (\k x y -> f x y) m1 m2+--+---- | /O(n+m)/. The intersection with a combining function.+--intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a+--intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = intersection1+--  | shorter m2 m1  = intersection2+--  | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)+--  | otherwise      = Nil+--  where+--    intersection1 | nomatch p2 p1 m1  = Nil+--                  | zero p2 m1        = intersectionWithKey f l1 t2+--                  | otherwise         = intersectionWithKey f r1 t2+--+--    intersection2 | nomatch p1 p2 m2  = Nil+--                  | zero p1 m2        = intersectionWithKey f t1 l2+--                  | otherwise         = intersectionWithKey f t1 r2+--+--intersectionWithKey f t1@(Tip k x) t2+--  = case lookup k t2 of+--      Just y  -> Tip k (f k x y)+--      Nothing -> Nil+--intersectionWithKey f t1 (Tip k y)+--  = case lookup k t1 of+--      Just x  -> Tip k (f k x y)+--      Nothing -> Nil+--intersectionWithKey f Nil t = Nil+--intersectionWithKey f t Nil = Nil+++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+--isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+--isProperSubmapOf m1 m2+--  = isProperSubmapOfBy (==) m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+--isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+--isProperSubmapOfBy pred t1 t2+--  = case submapCmp pred t1 t2 of+--      LT -> True+--      ge -> False+--+--submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = GT+--  | shorter m2 m1  = submapCmpLt+--  | p1 == p2       = submapCmpEq+--  | otherwise      = GT  -- disjoint+--  where+--    submapCmpLt | nomatch p1 p2 m2  = GT+--                | zero p1 m2        = submapCmp pred t1 l2+--                | otherwise         = submapCmp pred t1 r2+--    submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of+--                    (GT,_ ) -> GT+--                    (_ ,GT) -> GT+--                    (EQ,EQ) -> EQ+--                    other   -> LT+--+--submapCmp pred (Bin p m l r) t  = GT+--submapCmp pred (Tip kx x) (Tip ky y)+--  | (kx == ky) && pred x y = EQ+--  | otherwise              = GT  -- disjoint+--submapCmp pred (Tip k x) t+--  = case lookup k t of+--     Just y  | pred x y -> LT+--     other   -> GT -- disjoint+--submapCmp pred Nil Nil = EQ+--submapCmp pred Nil t   = LT+--+---- | /O(n+m)/. Is this a submap?+---- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+--isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+--isSubmapOf m1 m2+--  = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+{-++isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2+                                                      else isSubmapOfBy pred t1 r2)+  | otherwise      = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2+isSubmapOfBy pred (Bin p m l r) t  = False+isSubmapOfBy pred (Tip k x) t      = case lookup k t of+                                   Just y  -> pred x y+                                   Nothing -> False+isSubmapOfBy pred Nil t            = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntMap a -> IntMap b+map f m+  = mapWithKey (\k x -> f x) m++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k (f k x)+      Nil         -> Nil++-- | /O(n)/. The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f a m+  = mapAccumWithKey (\a k x -> f a x) a m++-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+  = case t of+      Bin p m l r -> let (a1,l') = mapAccumL f a l+                         (a2,r') = mapAccumL f a1 r+                     in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)+++-- | /O(n)/. The function @'mapAccumR'@ threads an accumulating+-- argument throught the map in descending order of keys.+mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumR f a t+  = case t of+      Bin p m l r -> let (a1,r') = mapAccumR f a r+                         (a2,l') = mapAccumR f a1 l+                     in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy some predicate.+filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+  = filterWithKey (\k x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy some predicate.+filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey pred t+  = case t of+      Bin p m l r+        -> bin p m (filterWithKey pred l) (filterWithKey pred r)+      Tip k x+        | pred k x  -> t+        | otherwise -> Nil+      Nil -> Nil++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+  = partitionWithKey (\k x -> p x) m++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey pred t+  = case t of+      Bin p m l r+        -> let (l1,l2) = partitionWithKey pred l+               (r1,r2) = partitionWithKey pred r+           in (bin p m l1 r1, bin p m l2 r2)+      Tip k x+        | pred k x  -> (t,Nil)+        | otherwise -> (Nil,t)+      Nil -> (Nil,Nil)++-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f m+  = mapMaybeWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey f Nil = Nil++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f (Bin p m l r)+  = (bin p m l1 r1, bin p m l2 r2)+  where+    (l1,l2) = mapEitherWithKey f l+    (r1,r2) = mapEitherWithKey f r+mapEitherWithKey f (Tip k x) = case f k x of+  Left y  -> (Tip k y, Nil)+  Right z -> (Nil, Tip k z)+mapEitherWithKey f Nil = (Nil, Nil)++-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+split :: Key -> IntMap a -> (IntMap a,IntMap a)+split k t+  = case t of+      Bin p m l r+          | m < 0 -> (if k >= 0 -- handle negative numbers.+                      then let (lt,gt) = split' k l in (union r lt, gt)+                      else let (lt,gt) = split' k r in (lt, union gt l))+          | otherwise   -> split' k t+      Tip ky y+        | k>ky      -> (t,Nil)+        | k<ky      -> (Nil,t)+        | otherwise -> (Nil,Nil)+      Nil -> (Nil,Nil)++split' :: Key -> IntMap a -> (IntMap a,IntMap a)+split' k t+  = case t of+      Bin p m l r+        | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)+        | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)+        | otherwise -> let (lt,gt) = split k r in (union l lt,gt)+      Tip ky y+        | k>ky      -> (t,Nil)+        | k<ky      -> (Nil,t)+        | otherwise -> (Nil,Nil)+      Nil -> (Nil,Nil)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup k t+  = case t of+      Bin p m l r+          | m < 0 -> (if k >= 0 -- handle negative numbers.+                      then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)+                      else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))+          | otherwise   -> splitLookup' k t+      Tip ky y+        | k>ky      -> (t,Nothing,Nil)+        | k<ky      -> (Nil,Nothing,t)+        | otherwise -> (Nil,Just y,Nil)+      Nil -> (Nil,Nothing,Nil)++splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup' k t+  = case t of+      Bin p m l r+        | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)+        | zero k m  -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)+        | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)+      Tip ky y+        | k>ky      -> (t,Nothing,Nil)+        | k<ky      -> (Nil,Nothing,t)+        | otherwise -> (Nil,Just y,Nil)+      Nil -> (Nil,Nothing,Nil)+      -}++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+fold :: (Int -> b -> b) -> b -> IntBag -> b+fold f z t+  = foldWithKey (\k x y -> f x y) z t++-- | /O(n)/. Fold the keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+-- For example,+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+--+foldWithKey :: (Key -> Int -> b -> b) -> b -> IntBag -> b+foldWithKey f z t+  = foldr f z t++foldr :: (Key -> Int -> b -> b) -> b -> IntBag -> b+foldr f z t+  = case t of+      Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r  -- put negative numbers before.+      Bin _ _ _ _ -> foldr' f z t+      Tip k x     -> f k x z+      Nil         -> z++foldr' :: (Key -> Int -> b -> b) -> b -> IntBag -> b+foldr' f z t+  = case t of+      Bin p m l r -> foldr' f (foldr' f z r) l+      Tip k x     -> f k x z+      Nil         -> z++++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+--elems :: IntMap a -> [a]+--elems m+--  = foldWithKey (\k x xs -> x:xs) [] m+--+---- | /O(n)/. Return all keys of the map in ascending order.+--keys  :: IntMap a -> [Key]+--keys m+--  = foldWithKey (\k x ks -> k:ks) [] m+--+---- | /O(n*min(n,W))/. The set of all keys of the map.+--keysSet :: IntMap a -> IntSet.IntSet+--keysSet m = IntSet.fromDistinctAscList (keys m)+++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+assocs :: IntBag -> [(Key,Int)]+assocs m = toList m+++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | /O(n)/. Convert the map to a list of key\/value pairs.+toList :: IntBag -> [(Key,Int)]+toList t+  = foldWithKey (\k x xs -> (k,x):xs) [] t++-- | /O(n)/. Convert the map to a list of key\/value pairs where the+-- keys are in ascending order.+toAscList :: IntBag -> [(Key,Int)]+toAscList t+  = -- NOTE: the following algorithm only works for big-endian trees+    let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+fromList :: [(Key,Int)] -> IntBag+fromList xs+  = foldlStrict ins empty xs+  where+    ins t (k,x)  = insert k x t+--+---- | /O(n*min(n,W))/.  Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+--fromListWith f xs+--  = fromListWithKey (\k x y -> f x y) xs+--+---- | /O(n*min(n,W))/.  Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+--fromListWithKey f xs+--  = foldlStrict ins empty xs+--  where+--    ins t (k,x) = insertWithKey f k x t+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order.+--fromAscList :: [(Key,a)] -> IntMap a+--fromAscList xs+--  = fromList xs+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order, with a combining function on equal keys.+--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+--fromAscListWith f xs+--  = fromListWith f xs+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order, with a combining function on equal keys.+--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+--fromAscListWithKey f xs+--  = fromListWithKey f xs+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order and all distinct.+--fromDistinctAscList :: [(Key,a)] -> IntMap a+--fromDistinctAscList xs+--  = fromList xs+++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq IntBag where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: IntBag -> IntBag -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal t1 t2   = False++nequal :: IntBag -> IntBag -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx x) (Tip ky y)+  = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal t1 t2   = True++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord IntBag where+    compare m1 m2 = compare (toList m1) (toList m2)+++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show IntBag where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++--showMap :: (Show a) => [(Key,a)] -> ShowS+--showMap []+--  = showString "{}"+--showMap (x:xs)+--  = showChar '{' . showElem x . showTail xs+--  where+--    showTail []     = showChar '}'+--    showTail (x:xs) = showChar ',' . showElem x . showTail xs+--+--    showElem (k,x)  = shows k . showString ":=" . shows x+--+--{--------------------------------------------------------------------+--  Read+----------------------------------------------------------------------}+--instance (Read e) => Read (IntMap e) where+-- #ifdef __GLASGOW_HASKELL__+--  readPrec = parens $ prec 10 $ do+--    Ident "fromList" <- lexP+--    xs <- readPrec+--    return (fromList xs)+--+--  readListPrec = readListPrecDefault+-- #else+--  readsPrec p = readParen (p > 10) $ \ r -> do+--    ("fromList",s) <- lex r+--    (xs,t) <- reads s+--    return (fromList xs,t)+-- #endif+--+--{--------------------------------------------------------------------+--  Typeable+----------------------------------------------------------------------}+--+-- #include "Typeable.h"+--INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")+--+--{--------------------------------------------------------------------+--  Debugging+----------------------------------------------------------------------}+---- | /O(n)/. Show the tree that implements the map. The tree is shown+---- in a compressed, hanging format.+--showTree :: Show a => IntMap a -> String+--showTree s+--  = showTreeWith True False s+--+--+--{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+-- the tree that implements the map. If @hang@ is+-- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+-- @wide@ is 'True', an extra wide version is shown.+---}+--showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+--showTreeWith hang wide t+--  | hang      = (showsTreeHang wide [] t) ""+--  | otherwise = (showsTree wide [] [] t) ""+--+--showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+--showsTree wide lbars rbars t+--  = case t of+--      Bin p m l r+--          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+--             showWide wide rbars .+--             showsBars lbars . showString (showBin p m) . showString "\n" .+--             showWide wide lbars .+--             showsTree wide (withEmpty lbars) (withBar lbars) l+--      Tip k x+--          -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"+--      Nil -> showsBars lbars . showString "|\n"+--+--showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+--showsTreeHang wide bars t+--  = case t of+--      Bin p m l r+--          -> showsBars bars . showString (showBin p m) . showString "\n" .+--             showWide wide bars .+--             showsTreeHang wide (withBar bars) l .+--             showWide wide bars .+--             showsTreeHang wide (withEmpty bars) r+--      Tip k x+--          -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"+--      Nil -> showsBars bars . showString "|\n"+--+--showBin p m+--  = "*" -- ++ show (p,m)+--+--showWide wide bars+--  | wide      = showString (concat (reverse bars)) . showString "|\n"+--  | otherwise = id+--+--showsBars :: [String] -> ShowS+--showsBars bars+--  = case bars of+--      [] -> id+--      _  -> showString (concat (reverse (tail bars))) . showString node+--+--node           = "+--"+--withBar bars   = "|  ":bars+--withEmpty bars = "   ":bars+--+--+{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Join+--------------------------------------------------------------------}+join :: Prefix -> IntBag -> Prefix -> IntBag -> IntBag+join p1 t1 p2 t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    m = branchMask p1 p2+    p = mask p1 m++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntBag -> IntBag -> IntBag+bin p m l Nil = l+bin p m Nil r = r+bin p m l r   = Bin p m l r+++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0++nomatch,_match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p++_match i p m+  = (mask i m) == p++mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))++{----------------------------------------------------------------------+  Finding the highest bit (mask) in a word [x] can be done efficiently in+  three ways:+  * convert to a floating point value and the mantissa tells us the+    [log2(x)] that corresponds with the highest bit position. The mantissa+    is retrieved either via the standard C function [frexp] or by some bit+    twiddling on IEEE compatible numbers (float). Note that one needs to+    use at least [double] precision for an accurate mantissa of 32 bit+    numbers.+  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+  * use processor specific assembler instruction (asm).++  The most portable way would be [bit], but is it efficient enough?+  I have measured the cycle counts of the different methods on an AMD+  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++  highestBitMask: method  cycles+                  --------------+                   frexp   200+                   float    33+                   bit      11+                   asm      12++  highestBit:     method  cycles+                  --------------+                   frexp   195+                   float    33+                   bit      11+                   asm      11++  Wow, the bit twiddling is on today's RISC like machines even faster+  than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+  [highestBitMask] returns a word where only the highest bit is set.+  It is found by first setting all bits in lower positions than the+  highest bit and than taking an exclusive or with the original value.+  Allthough the function may look expensive, GHC compiles this into+  excellent C code that subsequently compiled into highly efficient+  machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x+  = case (x .|. shiftRL x 1) of+     x -> case (x .|. shiftRL x 2) of+      x -> case (x .|. shiftRL x 4) of+       x -> case (x .|. shiftRL x 8) of+        x -> case (x .|. shiftRL x 16) of+         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms+          x -> (x `xor` (shiftRL x 1))+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree :: [Int] -> IntMap Int+testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (IntMap a) where+  arbitrary = do{ ks <- arbitrary+                ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks+                ; return (fromList xs)+                }+++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Key -> Int -> Bool+prop_Single k x+  = (insert k x empty == singleton k x)++prop_InsertDelete :: Key -> Int -> IntMap Int -> Property+prop_InsertDelete k x t+  = not (member k t) ==> delete k (insert k x t) == t++prop_UpdateDelete :: Key -> IntMap Int -> Bool+prop_UpdateDelete k t+  = update (const Nothing) k t == delete k t+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool+prop_UnionInsert k x t+  = union (singleton k x) t == insert k x t++prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: IntMap Int -> IntMap Int -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == unionWith (\x y -> y) t2 t1)+++prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Diff xs ys+  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))+    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))++prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Int xs ys+  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))+    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [(x,()) | x <- [0..n::Int]]+    in fromAscList xs == fromList xs++prop_List :: [Key] -> Bool+prop_List xs+  = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])+-}
+ src/Util/Interact.hs view
@@ -0,0 +1,227 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++-- This module contains routines to provide an interactive shell prompt and is+-- built on top of the readline library.++module Util.Interact(+    Interact(..),+    InteractCommand(..),+    beginInteraction,+    runInteraction,+    runInteractions,+    emptyInteract) where++import Data.Char+import Control.Monad.Identity+import Data.List+import qualified Data.Map as Map+#if defined(USE_HASKELINE)+import System.Console.Haskeline+import System.Console.Haskeline.IO+import Control.Exception+#elif defined(USE_EDITLINE)+import System.Console.Editline.Readline+#else+import System.Console.Readline+#endif+import System.Directory+import System.IO++import GenUtil+import Support.CompatMingw32++#ifndef USE_HASKELINE+readLine :: String -> (String -> IO [String]) -> IO String+readLine prompt tabExpand =  do+    setCompletionEntryFunction (Just (\s -> tabExpand s))+    s <- readline prompt+    case s of+        Nothing -> putStrLn "Bye!" >> exitSuccess+        Just cs | all isSpace cs -> return ""+        Just s -> addHistory s >> return s+#endif+++--simpleCommand :: String -> IO (Maybe String)++commands = [+    (":quit","quit interactive session"),+    (":version","print out version number"),+    (":cd", "change directory to argument"),+    (":pwd", "show current directory"),+    (":set", "set options"),+    (":unset", "unset options"),+    (":execfile", "run sequence of commands from a file"),+--    (":execfile!", "run sequence of commands from a file if it exists"),+    (":echo", "echo argument to screen"),+#ifndef USE_HASKELINE+    (":addhist", "add argument to command line history"),+#endif+    (":command", "enter command mode"),+    (":normal", "enter normal mode"),+    (":help", "print help table")+    ]++extra_help = [+    ("!command", "run shell command")+    ]++++basicParse :: Maybe String -> String ->  Either (String,String) String+basicParse comm s = f (cleanupWhitespace s) where+    f xs | Just c <- comm, c `isPrefixOf` xs = Right ""+    f (':':rs) = Left (':':dropWhile (== ':')  (map toLower as),dropWhile isSpace rest) where+        (as,rest) = span isAlpha rs+    f s = Right s++data InteractCommand = InteractCommand {+    commandName :: String,+    commandHelp :: String,+    commandAction :: Interact -> String -> String -> IO Interact+    }++data Interact = Interact {+    interactPrompt :: String,               -- ^ the prompt to use+    interactCommands :: [InteractCommand],  -- ^ a list of commands+    interactSettables :: [String],          -- ^ possible things that may be set+    interactVersion :: String,              -- ^ version string to print+    interactSet :: Map.Map String String,   -- ^ vars that are actually set+    interactExpr :: Interact -> String -> IO Interact, -- ^ what to run on a bare expression+    interactRC   :: [String],               -- ^ commands to run at startup+    interactWords :: [String],              -- ^ list of words to autocomplete+    interactEcho :: Bool,                   -- ^ whether to echo commands+    interactCommandMode :: Bool,                -- ^ whether we are in command mode+    interactHistFile :: Maybe String,       -- ^ filename to store history of commands in+    interactComment :: Maybe String         -- ^ comment initializer+    }++emptyInteract = Interact {+    interactPrompt = ">",+    interactCommands = [],+    interactSettables = [],+    interactVersion = "(none)",+    interactSet = Map.empty,+    interactExpr = \i s -> putStrLn ("Unknown Command: " ++ s) >> return i,+    interactRC = [],+    interactWords = [],+    interactEcho = False,+    interactCommandMode = False,+    interactHistFile = Nothing,+    interactComment = Nothing+    }++cleanupWhitespace s = reverse $ dropWhile isSpace (reverse $ dropWhile isSpace s)++runInteractions :: Interact -> [String] -> IO Interact+runInteractions act [] = return act+runInteractions act (x:xs) = do+    act' <- runInteraction act x+    runInteractions act' xs++thePrompt Interact { interactCommandMode = False, interactPrompt = p } = p+thePrompt Interact { interactCommandMode = True } = ":"++-- | run a command as if typed at prompt++runInteraction :: Interact -> String -> IO Interact+runInteraction act s = do+    act <- runInteractions act { interactRC = [] } (interactRC act)+    let commands' = commands ++ [ (n,h) | InteractCommand { commandName = n, commandHelp = h } <- interactCommands act ]+        help_text = unlines $ buildTableLL (commands' ++ extra_help)+    let args s =  [ bb | bb@(n,_) <- commands', s `isPrefixOf` n ]+--        expand s = fsts (args s) ++ filter (isPrefixOf s) (interactSettables act)++    let showSet+         | null $ interactSettables act = putStrLn "Nothing may be set"+         | otherwise  = do+            let set = [ "  " ++ if null b then a else a ++ "=" ++ b | (a,b) <- Map.toList $ interactSet act]+                setable = [ "  " ++ a | a <- sort $ interactSettables act, not $ a `Map.member` interactSet act]+            when (not $ null set) $ putStrLn "Set options:" >> putStr (unlines set)+            when (not $ null setable) $ putStrLn "Setable options:" >> putStr (unlines setable)+    case basicParse (interactComment act) (if interactCommandMode act then ':':s else s) of+        Right "" -> return act+        Right ('!':rest) -> systemCompat rest >> return act+        Right s -> do+            when (interactEcho act) $ putStrLn $ (interactPrompt act) ++ s+            act' <- interactExpr act act s+            return act'+        Left (cmd,arg) -> case fsts $ args cmd of+            [":quit"] -> putStrLn "Bye!" >> exitSuccess+            [":help"] -> putStrLn help_text >> return act+            [":version"] -> putStrLn (interactVersion act) >> return act+            [":echo"] -> putStrLn arg >> return act+#ifndef USE_HASKELINE+            [":addhist"] -> addHistory arg >> return act+#endif+            [":cd"] -> iocatch (setCurrentDirectory arg) (\_ -> putStrLn $ "Could not change to directory: " ++ arg) >> return act+            [":pwd"] -> (iocatch getCurrentDirectory (\_ -> putStrLn "Could not get current directory." >> return "") >>= putStrLn)  >> return act+            [":set"] -> case simpleUnquote arg of+                [] -> showSet >> return act+                rs -> do+                    let ts = [ let (a,b) = span (/= '=') x in (cleanupWhitespace a,drop 1 b) | x <- rs ]+                    sequence_ [ putStrLn $ "Unknown option: " ++ a | (a,_) <- ts, a `notElem` interactSettables act]+                    return act { interactSet = Map.fromList [ x | x@(a,_) <- ts, a `elem` interactSettables act ] `Map.union` interactSet act }+            [":unset"] -> return act { interactSet = interactSet act Map.\\ Map.fromList [ (cleanupWhitespace rs,"") | rs <- simpleUnquote arg] }+            [":execfile"] -> do+                fc <- iocatch (readFile arg) (\_ -> putStrLn ("Could not read file: " ++ arg) >> return "")+                act <- runInteractions act { interactEcho = True } (lines fc)+                return act { interactEcho = False }+            [":execfile!"] -> do+                fc <- iocatch (readFile arg) (\_ -> return "")+                runInteractions act { interactEcho = True } (lines fc)+            [":command"] -> return act { interactCommandMode = True }+            [":normal"] -> return act {interactCommandMode = False }+            [m] -> let [a] =  [ a | InteractCommand { commandName = n, commandAction = a } <-  interactCommands act, n == m] in do+                act' <- a act m arg+                return act'+            (_:_:_) -> putStrLn "Ambiguous command, possibilites are:" >> putStr  (unlines $ buildTableLL $ args cmd) >> return act+            [] -> (putStrLn $ "Unknown command (use :help for help): " ++ cmd)  >> return act+++-- | begin interactive interaction++beginInteraction :: Interact -> IO ()+beginInteraction act = do+    hist <- case interactHistFile act of+        Nothing -> return Nothing+        Just fn -> do+            ch <- iocatch (readFile fn >>= return . lines) (\_ -> return [])+            let cl = (map head $ group ch)+#ifndef USE_HASKELINE+            mapM_ addHistory cl+#endif+            putStrLn $ show (length cl) ++ " lines of history added from " ++ fn+            iocatch (openFile fn AppendMode >>= return . Just) (\_ -> return Nothing)+#if defined(USE_HASKELINE)+    bracketOnError (initializeInput $ setComplete noCompletion defaultSettings)+            cancelInput -- This will only be called if an exception such+                            -- as a SigINT is received.+            (\hd -> loop act hd >> closeInput hd)+    where+      loop :: Interact -> InputState -> IO ()+      loop act hd = do+        minput <- queryInput hd (getInputLine (thePrompt act))+        case minput of+          Nothing -> putStrLn "Bye!" >> exitSuccess+          Just cs | all isSpace cs -> loop act hd+          Just s -> do act' <- runInteraction act s+                       loop act' hd+#else+    go hist act+    where+    go hist act = do+        let commands' = commands ++ [ (n,h) | InteractCommand { commandName = n, commandHelp = h } <- interactCommands act ]+            args s =  [ bb | bb@(n,_) <- commands', s `isPrefixOf` n ]+            expand s = snub $ fsts (args s) ++ filter (isPrefixOf s) (interactSettables act ++ interactWords act)+        s <- readLine (thePrompt act) (return . expand)+        case (hist,s) of+            (Just h,(_:_)) -> do+                iocatch (hPutStrLn h s >> hFlush h) (const (return ()))+            _ -> return ()+        act' <- runInteraction act s+        go hist act'+#endif++
+ src/Util/NameMonad.hs view
@@ -0,0 +1,102 @@+module Util.NameMonad(NameMonad(..),GenName(..),NameMT,runNameMT,runNameMT',freeNames,mixInt,mixInt3,hashInt) where++import Control.Monad.State+import Data.Bits+import Data.Word+import qualified Data.Set as Set++-- | There are bound names and used names, the used names are always a superset of the bound names.+-- used names will not be chosen for any new bindings, bound names should be renamed if encountered.++class Monad m => NameMonad n m | m -> n  where+    -- | Add to list of used names+    addNames :: [n] -> m ()+    -- | Add to list of bound names+    addBoundNames :: [n] -> m ()+    -- | Choose a new name, adding it to both bound and used sets.+    newName :: m n+    -- | choose the first available name from list+    newNameFrom :: [n] -> m n+    -- | choose a new name if n is bound, else return n adding n to the bound names list+    uniqueName :: n -> m n++    -- in case we only have a concept of bound names+    addNames = addBoundNames++-- | Generating names.++class GenName n where+    -- | Generate a list of candidate names given a seed+    genNames :: Int -> [n]++instance GenName Int where+    genNames i = [st, st + 2 ..]  where+        st = abs i + 2 + abs i `mod` 2++-- | Generate an infinite list of names not present in the given set.+freeNames :: (Ord n,GenName n) => Set.Set n -> [n]+freeNames s  = filter (not . (`Set.member` s)) (genNames (Set.size s))++instance (Monad m, Monad (t m), MonadTrans t, NameMonad n m) => NameMonad n (t m) where+    addNames n = lift $ addNames n+    addBoundNames n = lift $ addBoundNames n+    newName = lift  newName+    newNameFrom y = lift $ newNameFrom y+    uniqueName y = lift $ uniqueName y++    --getNames = lift getNames++-- | Name monad transformer.+newtype NameMT n m a = NameMT (StateT (Set.Set n, Set.Set n) m a)+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)++-- | Run the name monad transformer.+runNameMT :: (Monad m) => NameMT a1 m a -> m a+runNameMT (NameMT x) = liftM fst $ runStateT x (Set.empty,Set.empty)++runNameMT' :: (Monad m) => NameMT a1 m a -> m (a,Set.Set a1)+runNameMT' (NameMT x) = do+    (r,(used,bound)) <- runStateT x (Set.empty,Set.empty)+    return (r,bound)++fromNameMT :: NameMT n m a -> StateT (Set.Set n, Set.Set n) m a+fromNameMT (NameMT x) = x++instance (GenName n,Ord n,Monad m) => NameMonad n (NameMT n m) where+    addNames ns = NameMT $ do+        modify (\ (used,bound) -> (Set.fromList ns `Set.union` used, bound) )+    addBoundNames ns = NameMT $ do+        let nset = Set.fromList ns+        modify (\ (used,bound) -> (nset `Set.union` used, nset `Set.union` bound) )+    uniqueName n = NameMT $ do+        (used,bound) <- get+        if n `Set.member` bound then fromNameMT newName else put (Set.insert n used,Set.insert n bound) >> return n+    newNameFrom vs = NameMT $ do+        (used,bound) <- get+        let f (x:xs)+                | x `Set.member` used = f xs+                | otherwise = x+            f [] = error "newNameFrom: finite list!"+            nn = f vs+        put (Set.insert nn used, Set.insert nn bound)+        return nn+    newName  = NameMT $ do+        (used,bound) <- get+        fromNameMT $ newNameFrom  (genNames (Set.size used `mixInt` Set.size bound))++hashInt :: Int -> Int+hashInt x = fromIntegral $ f (fromIntegral x) where+    f :: Word -> Word+    f a = a''''' where+        !a' = (a `xor` 61) `xor` (a `shiftR` 16)+        !a'' = a' + (a' `shiftL` 3)+        !a''' = a'' `xor` (a'' `shiftR` 4)+        !a'''' = a''' * 0x27d4eb2d+        !a''''' = a'''' `xor` (a'''' `shiftR` 15)++mixInt :: Int -> Int -> Int+mixInt x y = hashInt x - hashInt y++mixInt3 :: Int -> Int -> Int -> Int+mixInt3 x y z = (hashInt x - hashInt y) `xor` hashInt z+
+ src/Util/Once.hs view
@@ -0,0 +1,101 @@++-- | a simple type that only lets an IO action happen once, caching its result.++module Util.Once(+    Once,+    newOnce,+    runOnce,+    altOnce,++    OnceMap,+    newOnceMap,+    runOnceMap,+    altOnceMap,+    onceMapToList,+    onceMapKeys,+    onceMapElems++    ) where++import qualified Data.Map as Map+import Data.IORef+import Data.Dynamic++newtype Once a = Once (IORef (Maybe a))+    deriving(Typeable)+++-- | create a new Once object+newOnce :: IO (Once a)+newOnce = do+    ref <- newIORef Nothing+    return (Once ref)++-- | execute the action at most once, always returning the same result+runOnce :: Once a -> IO a -> IO a+runOnce (Once ref) action = do+    b <- readIORef ref+    case b of+        Just x -> return x+        Nothing -> do+            r <- action+            writeIORef ref (Just r)+            return r++-- | run first argument once, after which perform the second++altOnce :: Once () -> IO b -> IO b -> IO b+altOnce (Once ref) first second = do+    b <- readIORef ref+    case b of+        Just _ -> second+        Nothing -> do+            writeIORef ref (Just ())+            first+++-- | run an IO action at most once for each distinct argument++newtype OnceMap a b = OnceMap (IORef (Map.Map a b))+    deriving(Typeable)+++newOnceMap :: Ord a => IO (OnceMap a b)+newOnceMap = do+    r <- newIORef Map.empty+    return $ OnceMap r++runOnceMap :: Ord a => OnceMap a b -> a -> IO b -> IO b+runOnceMap (OnceMap r) x act = do+    m <- readIORef r+    case Map.lookup x m of+        Just y -> return y+        Nothing -> do+            y <- act+            modifyIORef r (Map.insert x y)+            return y++altOnceMap :: Ord a => OnceMap a () -> a -> IO b -> IO b -> IO b+altOnceMap (OnceMap ref) x first after = do+    m <- readIORef ref+    case Map.member x m of+        True -> after+        False -> do+            modifyIORef ref (Map.insert x ())+            first++onceMapToList :: OnceMap a b -> IO [(a,b)]+onceMapToList (OnceMap ref) = do+    m <- readIORef ref+    return $ Map.toList m++onceMapKeys :: OnceMap a b -> IO [a]+onceMapKeys (OnceMap ref) = do+    m <- readIORef ref+    return $ Map.keys m++onceMapElems :: OnceMap a b -> IO [b]+onceMapElems (OnceMap ref) = do+    m <- readIORef ref+    return $ Map.elems m+
+ src/Util/Perhaps.hs view
@@ -0,0 +1,19 @@+module Util.Perhaps where++import Data.Typeable+import Data.Monoid++data Perhaps = No | Maybe | Yes+    deriving(Show,Read,Typeable,Eq,Ord)+++-- the greatest lower bound was chosen as the Monoid+-- the least upper bound is just the maximum under Ord+instance Monoid Perhaps where+    mempty = No+    Yes `mappend` Yes = Yes+    No  `mappend` No  = No+    _   `mappend` _   = Maybe+++
+ src/Util/Progress.hs view
@@ -0,0 +1,176 @@+module Util.Progress(+    Progress(),+    progressNew,+    progressStep,+    progressIOSteps,+    progressIONew,+    progressSteps+    )where+++import System.IO+import Data.IORef+++data Progress k = Progress {+    pTreap :: Treap k Double,+    pIncrement,pDecrement,pBias,pTotal :: !Double+    }+++instance Show (Progress k) where+    showsPrec n pr = showsPrec n (toPercent $ pTotal pr) . showChar '%'+++progressIONew+    :: Int+    -> Int+    -> Char+    -> IO (IORef (Progress Char))+progressIONew nSteps nOut dChar = do+    let (pr,is) = progressStep (progressNew (nSteps + 1) nOut) dChar+    hPutStr stderr is+    newIORef pr+++progressIOSteps :: IORef (Progress Char) -> [Char] -> IO ()+progressIOSteps ref ks = do+    pr <- readIORef ref+    let (pr',os) = progressSteps pr ks+    hPutStr stderr os+    writeIORef ref pr'+++progressNew+    :: Int  -- ^ number of steps+    -> Int  -- ^ number of output positions+    -> Progress k+progressNew nSteps nOut = Progress {+    pTreap = Nil,+    pBias = - 0.5 / fromIntegral nOut ,+    pTotal = 0,+    pIncrement = 1.0 / fromIntegral nSteps,+    pDecrement = 1.0 / fromIntegral nOut+    }++progressSteps :: Ord k => Progress k -> [k] -> (Progress k,[k])+progressSteps pr ks = foldr fn (pr,[]) ks where+    fn k (pr,ks) = (pr',ks' ++ ks) where+        (pr',ks') = progressStep pr k++progressStep :: Ord k => Progress k -> k -> (Progress k,[k])+progressStep pr k = (pr { pTreap = ot, pBias = nb, pTotal = pTotal pr + pIncrement pr },ks) where+    dec = pDecrement pr+    itreap = insertWith (+) k (negate $ pIncrement pr) (pTreap pr)+    (ot,nb,ks) = f (pBias pr - pIncrement pr) itreap []+    f b t ks | b <= negate dec = f (b + dec) (insertWith (+) k dec t) (k:ks)+             | otherwise = (t,b,ks) where+        Just (k,_,_) = extract t++toPercent :: Double -> Double+toPercent d = (/ 100) . fromInteger $ round (d * 10000)++{-+histogram :: Ord k => [k] -> (Int,[(k,Int)])+histogram ks = mapSnd toListByPriority (foldr f (0,Nil) ks) where+    f k (n,t) = (n - 1,insertWith (+) k (-1) t)+    mapSnd f (x,y) = (x,f y)++histogramP :: Ord k => [k] -> [(k,Double)]+histogramP ks = [ (x,toPercent $ fromIntegral y / t) | (x,y) <- hs] where+    (ti,hs) = histogram ks+    t = fromIntegral ti++p = progressNew 7 10+p2 = progressNew 12 7+s7 = "..xxw.."+s12 = ".x.y.xx...x."++toListByPriority :: Treap k p -> [(k,p)]+toListByPriority t = f t [] where+    f Nil rs = rs+    f (Fork k p t1 t2) rs = f t1 ((k,p):f t2 rs)+-}++++data Treap k p = Nil | Fork k p (Treap k p) (Treap k p)+    deriving(Show)++{-+lookup :: Ord k => k -> Treap k p -> Maybe p+lookup k t = f t where+    f Nil = Nothing+    f (Fork k' p t1 t2) = case compare k k' of+        LT -> f t1+        GT -> f t2+        EQ -> Just p+-}++merge :: Ord p => Treap k p -> Treap k p -> Treap k p+merge Nil t = t+merge t Nil = t+merge a@(Fork kx x x1 x2) b@(Fork ky y y1 y2)+    | x > y = Fork kx x x1 (merge x2 b)+    | otherwise = Fork ky y (merge a y1) y2++extract :: (Ord k,Ord p) => Treap k p -> Maybe (k,p,Treap k p)+extract Nil = Nothing+extract (Fork kx x t1 t2) = Just (kx,x,merge t1 t2)++{-+fromList [] = Nil+fromList ((k,p):rs) = insert k p (fromList rs)+-}++insertWith :: (Ord k,Ord p) => (p -> p -> p) -> k -> p -> Treap k p -> Treap k p+insertWith fp k p t = f t where+    f Nil = Fork k p Nil Nil+    f (Fork k' p' t1 t2) = case compare k k' of+        LT -> ins k' p' (f t1) t2+        GT -> ins k' p' t1 (f t2)+        EQ -> ins k (fp p p') t1 t2++    ins k p Nil Nil = Fork k p Nil Nil+    ins k p (Fork k' p' l r) t2 | p > p' = Fork k' p' l (ins k p r t2)+    ins k p t1 (Fork k' p' l r) | p > p' = Fork k' p' (ins k p t1 l) r+    ins k p t1 t2 = Fork k p t1 t2++{-+insert :: (Ord k,Ord p) => k -> p -> Treap k p -> Treap k p+insert k p t = insertWith const k p t+-}++++-- very simple priority queue+++{-+data Heap a = Nil | Fork a (Heap a) (Heap a)++isEmpty Nil = True+isEmpty _ = False++minElem (Fork x a b) = Just (x,merge a b)+minElem _ = Nothing++insert x a = merge (Fork x Nil Nil) a++merge a Nil = a+merge Nil b = b+merge a@(Fork x _ _) b@(Fork y _ _)+    | x <= y = join a b+    | otherwise = join b a+    where+    join (Fork x a b) c = Fork x b (merge a c)+++discard :: Ord a => a -> Heap a -> Heap a+discard b h = f h where+    f Nil = Nil+    f (Fork x h1 h2)+        | x < b = merge (f h1) (f h2)+        | otherwise = merge h1 h2++-}
+ src/Util/RWS.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE BangPatterns #-}++-- modified from Control.Monad.RWS by John Meacham to be strict++module Util.RWS (+	RWS,+        runRWS,+--	evalRWS,+--	execRWS,+--	mapRWS,+--	withRWS,+--	RWST(..),+--	evalRWST,+--	execRWST,+--	mapRWST,+--	withRWST,+	module Control.Monad.Reader,+	module Control.Monad.Writer,+	module Control.Monad.State,+  ) where++import Prelude++import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State++++newtype RWS r w s a = RWS { runRWS' :: r -> s -> (# a, s, w #) }++runRWS :: RWS r w s a -> r -> s -> (a,s,w)+runRWS x r s = case runRWS' x r s of+    (# a, b, c #) -> (a,b,c)++instance Functor (RWS r w s) where+	fmap f m = RWS $ \r s -> case runRWS' m r s of+		(# a, s', w #) -> (# f a, s', w #)++instance (Monoid w) => Monad (RWS r w s) where+	return a = RWS $ \_ s -> (# a, s, mempty #)+	m >>= k  = RWS $ \r s -> case runRWS' m r s of+		(# a, s',  w #) -> case runRWS' (k a) r s' of+                    (# b, s'', w' #) -> let !w'' = w `mappend` w'+                        in (# b, s'', w'' #)++--instance (Monoid w) => MonadFix (RWS r w s) where+--	mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)++instance (Monoid w) => MonadReader r (RWS r w s) where+	ask       = RWS $ \r s -> (# r, s, mempty #)+	local f m = RWS $ \r s -> let !r' = f r in runRWS' m r' s++instance (Monoid w) => MonadWriter w (RWS r w s) where+	tell   w = RWS $ \_ s -> (# (), s, w #)+	listen m = RWS $ \r s -> case runRWS' m r s of+            (# a, s', w #) -> (# (a, w), s', w #)+	pass   m = RWS $ \r s -> case runRWS' m r s of+		(# (a, f), s', w #) -> let !w' = f w in (# a, s', w' #)++instance (Monoid w) => MonadState s (RWS r w s) where+	get   = RWS $ \_ s -> (# s, s, mempty #)+	put !s = RWS $ \_ _ -> (# (), s, mempty #)++{-+evalRWS :: RWS r w s a -> r -> s -> (a, w)+evalRWS m r s = let+    (a, _, w) = runRWS m r s+    in (a, w)++execRWS :: RWS r w s a -> r -> s -> (s, w)+execRWS m r s = let+    (_, s', w) = runRWS m r s+    in (s', w)++mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b+mapRWS f m = RWS $ \r s -> f (runRWS m r s)++withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a+withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)+++newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }++instance (Monad m) => Functor (RWST r w s m) where+	fmap f m = RWST $ \r s -> do+		(a, s', w) <- runRWST m r s+		return (f a, s', w)++instance (Monoid w, Monad m) => Monad (RWST r w s m) where+	return a = RWST $ \_ s -> return (a, s, mempty)+	m >>= k  = RWST $ \r s -> do+		(a, s', w)  <- runRWST m r s+		(b, s'',w') <- runRWST (k a) r s'+		return (b, s'', w `mappend` w')+	fail msg = RWST $ \_ _ -> fail msg++instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where+	mzero       = RWST $ \_ _ -> mzero+	m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s++instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where+	mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s++instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where+	ask       = RWST $ \r s -> return (r, s, mempty)+	local f m = RWST $ \r s -> runRWST m (f r) s++instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where+	tell   w = RWST $ \_ s -> return ((),s,w)+	listen m = RWST $ \r s -> do+		(a, s', w) <- runRWST m r s+		return ((a, w), s', w)+	pass   m = RWST $ \r s -> do+		((a, f), s', w) <- runRWST m r s+		return (a, s', f w)++instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where+	get   = RWST $ \_ s -> return (s, s, mempty)+	put s = RWST $ \_ _ -> return ((), s, mempty)++instance (Monoid w) => MonadTrans (RWST r w s) where+	lift m = RWST $ \_ s -> do+		a <- m+		return (a, s, mempty)++instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where+	liftIO = lift . liftIO+++evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)+evalRWST m r s = do+    (a, _, w) <- runRWST m r s+    return (a, w)++execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)+execRWST m r s = do+    (_, s', w) <- runRWST m r s+    return (s', w)++mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b+mapRWST f m = RWST $ \r s -> f (runRWST m r s)++withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)+-}
+ src/Util/ReaderWriter.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE UnboxedTuples #-}+module Util.ReaderWriter(ReaderWriter(),runReaderWriter) where++import Data.Monoid+import Control.Monad.Reader+import Control.Monad.Writer+-- strict unboxed ReaderWriter monad++newtype ReaderWriter r w a = ReaderWriter { _runReaderWriter :: r -> (# a, w #) }++runReaderWriter :: ReaderWriter r w a -> r -> (a,w)+runReaderWriter (ReaderWriter m) r = case m r of+    (# a, w #) -> (a,w)++instance Functor (ReaderWriter r w) where+	fmap f (ReaderWriter g) = ReaderWriter $ \r -> case g r of+            (# a, w #) -> (# f a, w #)++instance (Monoid w) => Monad (ReaderWriter r w) where+	return a = ReaderWriter $ \_ -> (# a, mempty #)+	(ReaderWriter m) >>= k  = ReaderWriter $ \r -> case m r of+            (# a,w #) -> case k a of+                ReaderWriter g -> case g r of+                    (# b, w' #) -> let w'' = w `mappend` w' in w'' `seq` (# b, w'' #)+        (ReaderWriter f) >> (ReaderWriter g) = ReaderWriter $ \r -> case f r of+            (# _, w #) -> case g r of+                (# a, w' #) -> let w'' = w `mappend` w' in w'' `seq` (# a, w'' #)++instance (Monoid w) => MonadWriter w (ReaderWriter r w) where+	tell   w = ReaderWriter $ \ _ -> w `seq` (# (), w #)+	listen (ReaderWriter m) = ReaderWriter $ \r -> case m r of+            (# a , w #) -> (# (a,w), w #)+	pass  (ReaderWriter m) = ReaderWriter $ \r -> case m r of+           (# (a, f), w #) -> let w' = f w in w' `seq` (# a, w' #)++instance Monoid w => MonadReader r (ReaderWriter r w) where+	ask       = ReaderWriter $ \r -> (# r, mempty #)+	local f (ReaderWriter m) = ReaderWriter $ \r -> m (f r)
+ src/Util/Relation.hs view
@@ -0,0 +1,81 @@++-- | extend Data.Set with relation operations++module Util.Relation where++import Data.Monoid+import Data.Set as Set hiding(map)+import Util.SetLike+import qualified Data.Set as Set+import qualified Data.Map as Map++newtype Rel a b = Rel (Map.Map a (Set b))+    deriving(Eq)++instance (Ord a,Ord b) => Monoid (Rel a b) where+    mempty = Rel mempty+    mappend (Rel r1) (Rel r2) = Rel $ Map.unionWith Set.union r1 r2++instance (Ord a,Ord b) => Unionize (Rel a b) where+    difference (Rel r1) (Rel r2) = Rel $ Map.differenceWith f r1 r2 where+        f r1 r2 = if Set.null rs then Nothing else Just rs where+            rs = Set.difference r1 r2+    intersection (Rel r1) (Rel r2) = prune $ Map.intersectionWith Set.intersection r1 r2++instance (Ord a,Ord b) => Collection (Rel a b) where+    fromList xs = Rel $ Map.fromListWith Set.union [ (x,Set.singleton y) | (x,y) <- xs ]+    toList (Rel r) = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys]++prune r = Rel $ Map.mapMaybe f r where+    f s = if Set.null s then Nothing else Just s+++type instance Elem (Rel a b) = (a,b)+type instance Key (Rel a b) = (a,b)+++domain :: (Ord a,Ord b) => Rel a b -> Set a+domain (Rel r) = Map.keysSet r++range :: (Ord a,Ord b) => Rel a b -> Set b+range (Rel r) = Set.unions $ Map.elems r++--flipRelation :: (Ord a, Ord b) => Rel a b -> Rel b a+--flipRelation (Rel r) = Rel $ Set.map (\ (x,y) -> (y,x)) r++restrictDomain :: (Ord a, Ord b) => (a -> Bool) -> Rel a b -> Rel a b+restrictDomain f (Rel r) = Rel $ Map.filterWithKey (\k _ -> f k) r++restrictDomainS :: (Ord a, Ord b) => a -> Rel a b -> Rel a b+restrictDomainS x (Rel r) = case Map.lookup x r of+    Nothing -> Rel mempty+    Just v -> Rel $ Map.singleton x v++restrictDomainSet :: (Ord a, Ord b) => Set a -> Rel a b -> Rel a b+restrictDomainSet s (Rel r) = Rel $ Map.filterWithKey (\k _ -> k `Set.member` s) r++restrictRange :: (Ord a, Ord b) => (b -> Bool) -> Rel a b -> Rel a b+restrictRange f (Rel r) = Rel $ Map.mapMaybe g r where+    g s = if Set.null ss then Nothing else Just ss where+        ss = Set.filter f s++mapDomain :: (Ord a, Ord b, Ord c) => (a -> c) -> Rel a b -> Rel c b+mapDomain f (Rel r) = Rel $ Map.mapKeys f r++mapRange :: (Ord a, Ord b, Ord c) => (b -> c) -> Rel a b -> Rel a c+mapRange f (Rel r) = Rel $ Map.map (Set.map f) r++partitionDomain f (Rel r) = case Map.partitionWithKey (\k _ -> f k) r of+    (x,y) -> (Rel x,Rel y)++--partitionRange f (Rel r) = Rel $ Set.partition (f . snd) r++--applyRelation :: (Ord a, Ord b) => Rel a b -> a -> [b]+--applyRelation r a = Prelude.map snd (Set.toList . unRel $ restrictDomain (== a) r)++unRel (Rel r) = r++toRelationList :: (Ord a, Ord b) => Rel a b -> [(a,[b])]+toRelationList (Rel r) = Map.toList (Map.map Set.toList r)+--toRelationList :: (Ord a, Ord b) => Rel a b -> [(a,[b])]+--toRelationList rel = [ (x, applyRelation rel x) | x <- Set.toList (domain rel)]
+ src/Util/SHA1.hs view
@@ -0,0 +1,280 @@+{-+Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>++Modified by Einar Karttunen to remove dependency on packed strings+and autoconf.++Modified by John Meacham for code cleanups.+++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, 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.++-}++{-# OPTIONS -funbox-strict-fields -fglasgow-exts -fno-warn-name-shadowing -O2 #-}++module Util.SHA1 (sha1String,sha1file,sha1Bytes,hashToBytes,sha1Handle,ABCDE(..),Hash,emptyHash) where+++import Control.Monad (unless)+import Data.Char (intToDigit,ord)+import Foreign+import Foreign.C+import System.IO+import System.IO.Unsafe (unsafePerformIO)++type Hash = ABCDE+data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32+    deriving(Eq,Ord)++emptyHash = ABCDE 0 0 0 0 0++data XYZ = XYZ !Word32 !Word32 !Word32++sha1String :: String -> Hash+sha1String ss = sha1Bytes (toUTF ss) where+    -- | Convert Unicode characters to UTF-8.+    toUTF :: String -> [Word8]+    toUTF [] = []+    toUTF (x:xs) | ord x<=0x007F = (fromIntegral $ ord x):toUTF xs+                 | ord x<=0x07FF = fromIntegral (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):+                                   fromIntegral (0x80 .|. (ord x .&. 0x3F)):+                                   toUTF xs+                 | otherwise     = fromIntegral (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):+                                   fromIntegral (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):+                                   fromIntegral (0x80 .|. (ord x .&. 0x3F)):+                                   toUTF xs+++sha1Bytes :: [Word8] -> Hash+sha1Bytes ss = unsafePerformIO $ do+    let len = length ss+        plen = sha1_step_1_2_plength len+    allocaBytes plen $ \ptr -> do+    pokeArray ptr ss+    let num_nuls = (55 - len) `mod` 64+    pokeArray (advancePtr ptr len) ((128:replicate num_nuls 0)++(reverse $ size_split 8 (fromIntegral len*8)))+    let abcde = sha1_step_3_init+    let ptr' = castPtr ptr+    unless big_endian $ fiddle_endianness ptr' plen+    res <- sha1_step_4_main abcde ptr' plen+    return res+++{-# NOINLINE sha1Handle #-}+sha1Handle :: Handle -> IO Hash+sha1Handle h = do+    hSeek h AbsoluteSeek 0+    len <- hFileSize h+    len <- return $ fromIntegral len+    let plen = sha1_step_1_2_plength len+    allocaBytes plen $ \ptr -> do+    cnt <- hGetBuf h ptr len+    unless (cnt == len) $ fail "sha1File - read returned too few bytes"+    hSeek h AbsoluteSeek 0+    let num_nuls = (55 - len) `mod` 64+    pokeArray (advancePtr ptr len) ((128:replicate num_nuls 0)++(reverse $ size_split 8 (fromIntegral len*8)))+    let abcde = sha1_step_3_init+    let ptr' = castPtr ptr+    unless big_endian $ fiddle_endianness ptr' plen+    res <- sha1_step_4_main abcde ptr' plen+    return res++{-# NOINLINE sha1file #-}+sha1file :: FilePath -> IO Hash+sha1file fp = do+    h   <- openBinaryFile fp ReadMode+    hash <- sha1Handle h+    hClose h+    return hash++big_endian = unsafePerformIO $ do+    let x :: Word32+        x = 0x12345678+    s <- with x $ \ptr -> peekCStringLen (castPtr ptr,4)+    case s of+      "\x12\x34\x56\x78" -> return True+      "\x78\x56\x34\x12" -> return False+      _                  -> error "Testing endianess failed"++fiddle_endianness :: Ptr Word32 -> Int -> IO ()+fiddle_endianness p 0 = p `seq` return ()+fiddle_endianness p n+ = do x <- peek p+      poke p $ shiftL x 24+           .|. shiftL (x .&. 0xff00) 8+           .|. (shiftR x 8 .&. 0xff00)+           .|. shiftR x 24+      fiddle_endianness (p `advancePtr` 1) (n - 4)++-- sha1_step_1_2_pad_length assumes the length is at most 2^61.+-- This seems reasonable as the Int used to represent it is normally 32bit,+-- but obviously could go wrong with large inputs on 64bit machines.+-- The PackedString library should probably move to Word64s if this is an+-- issue, though.+--+-- sha1_step_1_2_pad_length :: PackedString -> PackedString+-- sha1_step_1_2_pad_length s+--  = let len = lengthPS s+--        num_nuls = (55 - len) `mod` 64+--        padding = 128:replicate num_nuls 0+--        len_w8s = reverse $ size_split 8 (fromIntegral len*8)+--    in concatLenPS (len + 1 + num_nuls + 8)+--                   [s, packWords padding, packWords len_w8s]++sha1_step_1_2_plength :: Int -> Int+sha1_step_1_2_plength len = (len + 1 + num_nuls + 8) where num_nuls = (55 - len) `mod` 64+++size_split :: Int -> Integer -> [Word8]+size_split 0 _ = []+size_split p n = fromIntegral d:size_split (p-1) n'+ where (n', d) = divMod n 256++sha1_step_3_init :: ABCDE+sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0++sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE+sha1_step_4_main abcde _ 0 = return $! abcde+sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len+    = do+         (e, b) <- doit f1 0x5a827999 (x 0) a b c d e+         (d, a) <- doit f1 0x5a827999 (x 1) e a b c d+         (c, e) <- doit f1 0x5a827999 (x 2) d e a b c+         (b, d) <- doit f1 0x5a827999 (x 3) c d e a b+         (a, c) <- doit f1 0x5a827999 (x 4) b c d e a+         (e, b) <- doit f1 0x5a827999 (x 5) a b c d e+         (d, a) <- doit f1 0x5a827999 (x 6) e a b c d+         (c, e) <- doit f1 0x5a827999 (x 7) d e a b c+         (b, d) <- doit f1 0x5a827999 (x 8) c d e a b+         (a, c) <- doit f1 0x5a827999 (x 9) b c d e a+         (e, b) <- doit f1 0x5a827999 (x 10) a b c d e+         (d, a) <- doit f1 0x5a827999 (x 11) e a b c d+         (c, e) <- doit f1 0x5a827999 (x 12) d e a b c+         (b, d) <- doit f1 0x5a827999 (x 13) c d e a b+         (a, c) <- doit f1 0x5a827999 (x 14) b c d e a+         (e, b) <- doit f1 0x5a827999 (x 15) a b c d e+         (d, a) <- doit f1 0x5a827999 (m 16) e a b c d+         (c, e) <- doit f1 0x5a827999 (m 17) d e a b c+         (b, d) <- doit f1 0x5a827999 (m 18) c d e a b+         (a, c) <- doit f1 0x5a827999 (m 19) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a+         let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)+         sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64)+ where {-# INLINE f1 #-}+       f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z)+       {-# INLINE f2 #-}+       f2 (XYZ x y z) = x `xor` y `xor` z+       {-# INLINE f3 #-}+       f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)+       {-# INLINE x #-}+       x n = peek (s `advancePtr` n)+       {-# INLINE m #-}+       m n = do let base = s `advancePtr` (n .&. 15)+                x0 <- peek base+                x1 <- peek (s `advancePtr` ((n - 14) .&. 15))+                x2 <- peek (s `advancePtr` ((n - 8) .&. 15))+                x3 <- peek (s `advancePtr` ((n - 3) .&. 15))+                let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1+                poke base res+                return res+       {-# INLINE doit #-}+       doit f k i a b c d e = a `seq` c `seq`+           do i' <- i+              return (rotateL a 5 + f (XYZ b c d) + e + i' + k,+                      rotateL b 30)++hashToBytes :: Hash -> [Word8]+hashToBytes (ABCDE a b c d e) = tb a . tb b . tb c . tb d . tb e $ [] where+    tb :: Word32 -> [Word8] -> [Word8]+    tb n = showIt 4 n+    showIt :: Int -> Word32 -> [Word8] -> [Word8]+    showIt 0 _ r = r+    showIt i x r = case quotRem x 256 of+                       (y, z) -> let c = fromIntegral z+                                 in c `seq` showIt (i-1) y (c:r)+++instance Show ABCDE where+    showsPrec _ (ABCDE a b c d e) = showAsHex a . showAsHex b . showAsHex c . showAsHex d . showAsHex e++showAsHex :: Word32 -> ShowS+showAsHex n = showIt 8 n+   where+    showIt :: Int -> Word32 -> String -> String+    showIt 0 _ r = r+    showIt i x r = case quotRem x 16 of+                       (y, z) -> let c = intToDigit (fromIntegral z)+                                 in c `seq` showIt (i-1) y (c:r)+
+ src/Util/SameShape.hs view
@@ -0,0 +1,45 @@+module Util.SameShape where++import Data.Tree++++--class SameShape a b where+--    sameShape :: a -> b -> Bool++--instance (SameShape1 f) => SameShape (f a) (f b) where+--    sameShape x y = sameShape1 x y+--instance (SameShape2 f) => SameShape (f a b) (f c d) where+--    sameShape x y = sameShape2 x y++class SameShape1 f where+    sameShape1 :: f a -> f b -> Bool+class SameShape2 f where+    sameShape2 :: f a b -> f c d -> Bool+++instance SameShape1 [] where+    sameShape1 [] [] = True+    sameShape1 (_:xs) (_:ys) = sameShape1 xs ys+    sameShape1 _ _ = False++instance SameShape1 Tree where+    sameShape1 (Node _ xs) (Node _ ys) = f xs ys where+        f [] [] = True+        f (x:xs) (y:ys) = sameShape1 x y && f xs ys+        f _ _ = False++instance SameShape1 Maybe where+    sameShape1 (Just _) (Just _) = True+    sameShape1 Nothing Nothing = True+    sameShape1 _ _ = False++instance SameShape2 Either where+    sameShape2 (Left _) (Left _) = True+    sameShape2 (Right _) (Right _) = True+    sameShape2 _ _ = False++instance SameShape1 IO where+    sameShape1 _ _ = True++
+ src/Util/Seq.hs view
@@ -0,0 +1,121 @@+--------------------------------------------------------------------------------+{-| Module      :  Seq+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An implementation of John Hughes's efficient catenable sequence type. A lazy sequence+  @Seq a@ can be concatenated in /O(1)/ time. After+  construction, the sequence in converted in /O(n)/ time into a list.++  Modified by John Meacham for use in jhc+-}+---------------------------------------------------------------------------------}+module Util.Seq( -- * Type+            Seq+            -- * Operators+          , (<>)++            -- * Construction+          , empty+          , single+          , singleton+          , cons+          , append++            -- * Conversion+          , toList+          , fromList+          ) where++import Data.Monoid(Monoid(..))+import Control.Monad++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixr 5 <>++-- | /O(1)/. Append two sequences, see 'append'.+(<>) :: Seq a -> Seq a -> Seq a+s <> t+  = append s t++{--------------------------------------------------------------------+  Type+--------------------------------------------------------------------}+-- | Sequences of values @a@.+newtype Seq a = Seq ([a] -> [a])+++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. Create an empty sequence.+empty :: Seq a+empty+  = Seq (\ts -> ts)++-- | /O(1)/. Create a sequence of one element.+single :: a -> Seq a+single x+  = Seq (\ts -> x:ts)++-- | /O(1)/. Create a sequence of one element.+singleton :: a -> Seq a+singleton x = single x++-- | /O(1)/. Put a value in front of a sequence.+cons :: a -> Seq a -> Seq a+cons x (Seq f)+  = Seq (\ts -> x:f ts)++-- | /O(1)/. Append two sequences.+append :: Seq a -> Seq a -> Seq a+append (Seq f) (Seq g)+  = Seq (\ts -> f (g ts))+++{--------------------------------------------------------------------+  Conversion+--------------------------------------------------------------------}+-- | /O(n)/. Convert a sequence to a list.+toList :: Seq a -> [a]+toList (Seq f)+  = f []++-- | /O(n)/. Create a sequence from a list.+fromList :: [a] -> Seq a+fromList xs+  = Seq (\ts -> xs++ts)+++--tell x = W.tell (Util.Seq.singleton x)+--tells xs = W.tell (Util.Seq.fromList xs)+++concat :: Seq (Seq a) -> Seq a+concat (Seq f) = (foldr Util.Seq.append Util.Seq.empty (f []))++instance Functor Util.Seq.Seq where+    --fmap f xs = Seq.fromList (map f (Seq.toList xs))+    fmap f (Seq xs) = Seq (\ts -> map f (xs []) ++ ts )++instance Monad Util.Seq.Seq where+    --a >>= b  = mconcat ( fmap b (Seq.toList a))+    a >>= b  = Util.Seq.concat (fmap b a)+    return x = Util.Seq.single x+    fail _ = Util.Seq.empty++instance MonadPlus Util.Seq.Seq where+    mplus = mappend+    mzero = Util.Seq.empty+++instance Monoid (Seq a) where+    mempty = empty+    mappend = append+
+ src/Util/SetLike.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS -XTypeFamilies #-}+module Util.SetLike where++import Data.List(foldl')+import Data.Monoid+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Set as S+import qualified Data.IntSet as IS+import Util.HasSize+import Data.Foldable hiding(toList, foldl')+import Data.Traversable++infixl 9 \\ --++(\\) :: Unionize s => s -> s -> s+m1 \\ m2 = difference m1 m2++class Monoid s => Unionize s where+    union :: s -> s -> s+    difference :: s -> s -> s+    intersection :: s -> s -> s+    unions :: [s] -> s+    sempty :: s++    sempty = mempty+    union = mappend+    unions = foldl' union mempty++type family Elem es :: *+type family Key s :: *+type family Value m :: *++class Monoid s => Collection s where+    fromList :: [Elem s] -> s+    fromDistinctAscList :: [Elem s] -> s+    toList :: s -> [Elem s]+    singleton :: Elem s -> s+    singleton e = fromList [e]++    fromDistinctAscList = fromList++class Collection s => SetLike s where+    keys :: s -> [Key s]+    member :: Key s -> s -> Bool+    delete :: Key s -> s -> s+    sfilter :: (Elem s -> Bool) -> s -> s+    insert :: Elem s -> s -> s+    spartition :: (Elem s -> Bool) -> s -> (s,s)++notMember :: SetLike s => Key s -> s -> Bool+notMember k s = not $ member k s++class SetLike m => MapLike m where+    mlookup :: Key m -> m -> Maybe (Value m)+    values :: m -> [Value m]+    unionWith :: (Value m -> Value m -> Value m) -> m -> m -> m++instance Unionize IS.IntSet where+    union = IS.union+    difference = IS.difference+    intersection = IS.intersection++type instance Elem IS.IntSet = Int++instance Collection IS.IntSet where+    fromList = IS.fromList+    toList = IS.toList+    singleton = IS.singleton+    fromDistinctAscList = IS.fromDistinctAscList++type instance  Key IS.IntSet = Int+instance SetLike IS.IntSet where+    keys = IS.toList+    member = IS.member+    sfilter = IS.filter+    delete = IS.delete+    insert = IS.insert+    spartition = IS.partition++instance Ord k => Unionize (S.Set k) where+    union = S.union+    intersection = S.intersection+    difference = S.difference++type instance  Elem (S.Set k) = k+instance Ord k => Collection (S.Set k) where+    fromList = S.fromList+    toList = S.toList+    singleton = S.singleton+    fromDistinctAscList = S.fromDistinctAscList++type instance Key (S.Set k) = k+instance Ord k => SetLike (S.Set k) where+    keys = S.toList+    member = S.member+    sfilter = S.filter+    delete = S.delete+    insert = S.insert+    spartition = S.partition++instance Unionize (IM.IntMap v) where+    union = IM.union+    difference = IM.difference+    intersection = IM.intersection++type instance Elem (IM.IntMap v) = (Int,v)+instance Collection (IM.IntMap v) where+    fromList = IM.fromList+    toList = IM.toList+    singleton (k,v) = IM.singleton k v+    fromDistinctAscList = IM.fromDistinctAscList++type instance Key (IM.IntMap v) = Int+instance SetLike (IM.IntMap v) where+    keys = IM.keys+    member = IM.member+    sfilter f = IM.filterWithKey (\ k v -> f (k,v))+    delete = IM.delete+    insert (k,v) = IM.insert k v+    spartition f = IM.partitionWithKey (\ k v -> f (k,v))++type instance Value (IM.IntMap v) = v+instance MapLike (IM.IntMap v) where+    mlookup = IM.lookup+    values = IM.elems+    unionWith = IM.unionWith++instance Ord k => Unionize (M.Map k v) where+    union = M.union+    difference = M.difference+    intersection = M.intersection++type instance Elem (M.Map k v) = (k,v)+instance Ord k => Collection (M.Map k v) where+    fromList = M.fromList+    toList = M.toList+    singleton (k,v) = M.singleton k v+    fromDistinctAscList = M.fromDistinctAscList++type instance Key (M.Map k v) = k+instance Ord k => SetLike (M.Map k v) where+    keys = M.keys+    member = M.member+    sfilter f = M.filterWithKey (\ k v -> f (k,v))+    delete = M.delete+    insert (k,v) = M.insert k v+    spartition f = M.partitionWithKey (\ k v -> f (k,v))++type instance Value (M.Map k v) = v+instance Ord k => MapLike (M.Map k v) where+    mlookup = M.lookup+    values = M.elems+    unionWith = M.unionWith++minsert :: (MapLike m, Elem m ~ (k,v)) => k -> v -> m -> m+minsert k v = insert (k,v)++msingleton :: (MapLike m, Elem m ~ (k,v)) => k -> v -> m+msingleton k v = singleton (k,v)++intersects x y = not $ isEmpty (x `intersection` y)++findWithDefault :: MapLike m => Value m -> Key m -> m -> Value m+findWithDefault d k m = case mlookup k m of+    Nothing -> d+    Just x -> x++newtype EnumSet a = EnumSet IS.IntSet+    deriving(Monoid,IsEmpty,HasSize,Unionize,Eq,Ord)++type instance Elem (EnumSet a) = a+type instance Key (EnumSet a) = a++instance Enum a => Collection (EnumSet a) where+    singleton i = EnumSet $ singleton (fromEnum i)+    fromList ts = EnumSet $ fromList (map fromEnum ts)+    toList (EnumSet w) = map toEnum $ toList w++instance Enum a => SetLike (EnumSet a) where+    keys = toList+    delete (fromEnum -> i) (EnumSet v) = EnumSet $ delete i v+    member (fromEnum -> i) (EnumSet v) = member i v+    insert (fromEnum -> i) (EnumSet v) = EnumSet $ insert i v+    sfilter f (EnumSet v) = EnumSet $ sfilter (f . toEnum) v+    spartition f (EnumSet v) = case spartition (f . toEnum) v of+        (x,y) -> (EnumSet x,EnumSet y)++newtype EnumMap k v = EnumMap (IM.IntMap v)+    deriving(Monoid,IsEmpty,Functor,Foldable,Traversable,HasSize,Unionize,Eq,Ord)++type instance Elem (EnumMap k v) = (k,v)+type instance Key (EnumMap k v) = k+type instance Value (EnumMap k v) = v++instance Enum k => Collection (EnumMap k v) where+    singleton (k,v) = EnumMap $ singleton (fromEnum k,v)+    fromList ts = EnumMap $ fromList [ (fromEnum k,v) | (k,v) <- ts ]+    toList (EnumMap kv) =  [ (toEnum k,v)  | (k,v) <-  toList kv]++instance Enum k => SetLike (EnumMap k v) where+    keys (EnumMap v) = map toEnum $ keys v+    delete (fromEnum -> i) (EnumMap v) = EnumMap $ delete i v+    member (fromEnum -> i) (EnumMap v) = member i v+    insert (fromEnum -> k,v) (EnumMap m) = EnumMap $ insert (k,v) m+    sfilter f (EnumMap v) = EnumMap $ sfilter (\ (k,v) -> f (toEnum k,v)) v+    spartition f (EnumMap v) = case spartition (\ (k,v) -> f (toEnum k,v)) v of+        (x,y) -> (EnumMap x,EnumMap y)++instance Enum k => MapLike (EnumMap k v) where+    mlookup (fromEnum -> i) (EnumMap v) = mlookup i v+    values (EnumMap v) = values v+    unionWith f (EnumMap x) (EnumMap y) = EnumMap $ unionWith f x y++-- must be an injection into the integers+class Intjection a where+    fromIntjection :: a -> Int+    toIntjection :: Int -> a++newtype IntjectionSet a = IntjectionSet IS.IntSet+    deriving(Monoid,IsEmpty,HasSize,Unionize,Eq,Ord)++instance (Intjection a,Show a) => Show (IntjectionSet a) where+    showsPrec n is = showsPrec n $ toList is++type instance Elem (IntjectionSet a) = a+type instance Key (IntjectionSet a) = a++instance Intjection a => Collection (IntjectionSet a) where+    singleton i = IntjectionSet $ singleton (fromIntjection i)+    fromList ts = IntjectionSet $ fromList (map fromIntjection ts)+    toList (IntjectionSet w) = map toIntjection $ toList w++instance Intjection a => SetLike (IntjectionSet a) where+    keys = toList+    delete (fromIntjection -> i) (IntjectionSet v) = IntjectionSet $ delete i v+    member (fromIntjection -> i) (IntjectionSet v) = member i v+    insert (fromIntjection -> i) (IntjectionSet v) = IntjectionSet $ insert i v+    sfilter f (IntjectionSet v) = IntjectionSet $ sfilter (f . toIntjection) v+    spartition f (IntjectionSet v) = case spartition (f . toIntjection) v of+        (x,y) -> (IntjectionSet x,IntjectionSet y)++newtype IntjectionMap k v = IntjectionMap (IM.IntMap v)+    deriving(Monoid,IsEmpty,Functor,Foldable,Traversable,HasSize,Unionize,Eq,Ord)++type instance Elem (IntjectionMap k v) = (k,v)+type instance Key (IntjectionMap k v) = k+type instance Value (IntjectionMap k v) = v++instance Intjection k => Collection (IntjectionMap k v) where+    singleton (k,v) = IntjectionMap $ singleton (fromIntjection k,v)+    fromList ts = IntjectionMap $ fromList [ (fromIntjection k,v) | (k,v) <- ts ]+    toList (IntjectionMap kv) =  [ (toIntjection k,v)  | (k,v) <-  toList kv]++instance Intjection k => SetLike (IntjectionMap k v) where+    keys (IntjectionMap v) = map toIntjection $ keys v+    delete (fromIntjection -> i) (IntjectionMap v) = IntjectionMap $ delete i v+    member (fromIntjection -> i) (IntjectionMap v) = member i v+    insert (fromIntjection -> k,v) (IntjectionMap m) = IntjectionMap $ insert (k,v) m+    sfilter f (IntjectionMap v) = IntjectionMap $ sfilter (\ (k,v) -> f (toIntjection k,v)) v+    spartition f (IntjectionMap v) = case spartition (\ (k,v) -> f (toIntjection k,v)) v of+        (x,y) -> (IntjectionMap x,IntjectionMap y)++instance Intjection k => MapLike (IntjectionMap k v) where+    mlookup (fromIntjection -> i) (IntjectionMap v) = mlookup i v+    values (IntjectionMap v) = values v+    unionWith f (IntjectionMap x) (IntjectionMap y) = IntjectionMap $ unionWith f x y+
+ src/Util/TrueSet.hs view
@@ -0,0 +1,60 @@+module Util.TrueSet(+    TrueSet,+    fromList,+    member,+    empty,+    full,+    singleton,+    insert,+    delete,+    unions,+    union,+    intersection,+    intersects,+    difference,+    (\\)+    ) where++import qualified Data.Set as Set++infixl 9 \\+++data TrueSet a = TrueSet (Set.Set a) Bool++False `xor` y = y+True `xor` y = not y++fromList xs = TrueSet (Set.fromList xs) False+member x (TrueSet s inv) = inv `xor` (Set.member x s)++invert (TrueSet x y) = TrueSet x (not y)+empty = TrueSet Set.empty False+full = TrueSet Set.empty False+singleton x = TrueSet (Set.singleton x) False+insert x (TrueSet s False) = TrueSet (Set.insert x s) False+insert x (TrueSet s True) = TrueSet (Set.delete x s) True+delete x (TrueSet s False) = TrueSet (Set.delete x s) False+delete x (TrueSet s True) = TrueSet (Set.insert x s) True++unions xs = foldlStrict union empty xs+intersects xs = foldlStrict intersection full xs++foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)++difference x y = x `intersection` invert y+m1 \\ m2 = difference m1 m2++(TrueSet x True)  `intersection` (TrueSet y True) = TrueSet (x `Set.union` y) True+(TrueSet x False) `intersection` (TrueSet y False) = TrueSet (x `Set.intersection` y) False+(TrueSet x True)  `intersection` (TrueSet y False) = TrueSet (y Set.\\ x) False+(TrueSet x False) `intersection` (TrueSet y True) = TrueSet (x Set.\\ y) False+(TrueSet x True)  `union` (TrueSet y True) = TrueSet (x `Set.intersection` y) True+(TrueSet x False) `union` (TrueSet y False) = TrueSet (x `Set.union` y) False+(TrueSet x True)  `union` (TrueSet y False) = TrueSet (x Set.\\ y) True+(TrueSet x False) `union` (TrueSet y True) = TrueSet (y Set.\\ x) True++
+ src/Util/UnionFind.hs view
@@ -0,0 +1,90 @@+module Util.UnionFind(+    Element,+    T,+    find,+    fromElement,+    getW,+    new,+    new_,+    putW,+    union,+    union_,+    updateW+    ) where++import Control.Monad.Trans+import Data.IORef+import Data.Unique+import Control.Monad (when)++data Element w a = Element a !Unique {-# UNPACK #-} !(IORef (Link w a))+data Link w a = Weight {-# UNPACK #-} !Int w | Next (Element w a)++type T = Element++new :: MonadIO m => w -> a -> m (Element w a)+new w x = liftIO $  do+    r <- newIORef (Weight 1 w)+    n <- newUnique+    return $ Element x n r++new_ :: MonadIO m => a -> m (Element () a)+new_ x = new () x++find :: MonadIO m => Element w a -> m (Element w a)+find x@(Element a _ r) = liftIO $  do+    e <- readIORef r+    case e of+        Weight _ _ -> return x+        Next next -> do+            last <- Util.UnionFind.find next+            when (next /= last) $ writeIORef r (Next last)+            return last++getW :: MonadIO m => Element w a -> m w+getW x = liftIO $ do+    Element _ _ r <- find x+    Weight _ w <- readIORef  r+    return w++updateW :: MonadIO m => (w -> w) -> Element w a -> m ()+updateW f x = liftIO $ do+    Element _ _ r <- find x+    modifyIORef r (\ (Weight s w) -> Weight s (f w))++putW :: MonadIO m => Element w a -> w -> m ()+putW e w = liftIO $ do+    Element _ _ r <- find e+    modifyIORef r (\ (Weight s _) -> Weight s w)++union :: MonadIO m => (w -> w -> w) -> Element w a -> Element w a -> m ()+union comb e1 e2 = liftIO $ do+    e1'@(Element _ _ r1) <- find e1+    e2'@(Element _ _ r2) <- find e2+    when (r1 /= r2) $ do+        Weight w1 x1 <- readIORef r1+        Weight w2 x2 <- readIORef r2+        if w1 <= w2 then do+            writeIORef r1 (Next e2')+            writeIORef r2 $! (Weight (w1 + w2) (comb x1 x2))+          else do+            writeIORef r1 $! (Weight (w1 + w2) (comb x1 x2))+            writeIORef r2 (Next e1')++union_ :: MonadIO m =>  Element () a -> Element () a -> m ()+union_ x y = union (\_ _ -> ()) x y++fromElement :: Element w a -> a+fromElement (Element a _ _) = a++instance Eq (Element w a) where+    Element _ x _ == Element _ y _ = x == y+    Element _ x _ /= Element _ y _ = x /= y++instance Ord (Element w a) where+    Element _ x _ `compare` Element _ y _ = x `compare` y+    Element _ x _ <= Element _ y _ = x <= y+    Element _ x _ >= Element _ y _ = x >= y++instance Show a => Show (Element w a) where+    showsPrec n (Element x _ _) = showsPrec n x
+ src/Util/UnionSolve.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Util.UnionSolve(+    C(),+    solve,+    Fixable(..),+    Topped(..),+    Result(..),+    cAnnotate,+    islte,isgte,equals,+    (@<=),(@>=),(@=),(@<=@),(@>=@),(@=@)+    ) where++import Control.Monad(unless, forM_)+import Data.List(intersperse)+import Data.Monoid+import qualified Data.Foldable as S+import qualified Data.Map as Map+import qualified Data.Sequence as S+import qualified Data.Set as Set++import Util.UnionFind as UF++-- simple constraint solver based on ideas from 'Once upon a polymorphic type' paper.++class Fixable a where+    -- determine if we are at the top or bottom of the lattice, we can+    -- solidify bounds if we know we are at an endpoint.+    isBottom :: a -> Bool+    isTop :: a -> Bool+    -- lattice operators+    join :: a -> a -> a+    meet :: a -> a -> a+    eq :: a -> a -> Bool+    lte :: a -> a -> Bool+    -- used for debugging+    showFixable :: a -> String+    -- default methods+    showFixable x | isBottom x = "B"+                  | isTop x = "T"+                  | otherwise = "*"+    eq x y = lte x y && lte y x+    isBottom _ = False+    isTop _ = False++-- arguments are the lattice and the variable type+-- mappended together when used in a writer monad.+-- (C l v) represents a constraint (or set of constraints) that confine the+-- variables 'v' to within specific values of 'l'++newtype C l v = C (S.Seq (CL l v))+    deriving(Monoid)++data Op = OpLte | OpEq | OpGte++{-+flipOp OpLte = OpGte+flipOp OpGte = OpLte+flipOp OpEq = OpEq+-}++instance Show Op where+    show OpEq  = " = "+    show OpGte = " >= "+    show OpLte = " <= "++data CL l v = CV v Op v | CL v Op l | CLAnnotate String (CL l v)++cAnnotate :: String -> C l v -> C l v+cAnnotate s (C seq) = C (fmap (CLAnnotate s) seq)++instance (Show e,Show l) => Show (C l e) where+    showsPrec _ (C xs) = showString "" . foldr (.) id (intersperse (showString "\n") (map shows (S.toList xs))) . showString "\n"++instance (Show e,Show l) => Show (CL l e) where+    showsPrec _ x = case x of+        CV v1 op v2 -> shows v1 . shows op . shows v2+        CL v1 op v2 -> shows v1 . shows op . shows v2+        CLAnnotate _ c -> shows c++bool t f b = if b then t else f++-- operator constraits, the @ is on the side that takes a variable.+v @<= l = cL v OpLte l+v @>= l = cL v OpGte l+v @=  l = cL v OpEq l+v @<=@ l = cV v OpLte l+v @>=@ l = cV v OpGte l+v @=@  l = cV v OpEq l++cL x y z = C (S.singleton (CL x y z))+cV x y z = C (S.singleton (CV x y z))++-- basic constraints+islte,isgte,equals :: (Fixable l,Ord v) => Either v l -> Either v l -> C l v+islte (Left v1) (Left v2)   = C (S.singleton (CV v1 OpLte v2))+islte (Left v1) (Right v2)  = C (S.singleton (CL v1 OpLte v2))+islte (Right v1) (Left v2)  = C (S.singleton (CL v2 OpGte v1))+islte (Right l1) (Right l2) = bool mempty (error $ "invalid constraint: " ++ showFixable l1 ++ " <= " ++ showFixable l2) (l1 `lte` l2)++isgte (Left v1) (Left v2)   = C (S.singleton (CV v1 OpGte v2))+isgte (Left v1) (Right v2)  = C (S.singleton (CL v1 OpGte v2))+isgte (Right v1) (Left v2)  = C (S.singleton (CL v2 OpLte v1))+isgte (Right l1) (Right l2) = bool mempty (error $ "invalid constraint: " ++ showFixable l1 ++ " >= " ++ showFixable l2) (l2 `lte` l1)++equals (Left v1) (Left v2)   = C (S.singleton (CV v1 OpEq v2))+equals (Left v1) (Right v2)  = C (S.singleton (CL v1 OpEq v2))+equals (Right v1) (Left v2)  = C (S.singleton (CL v2 OpEq v1))+equals (Right l1) (Right l2) = bool mempty (error $ "invalid constraint: " ++ showFixable l1 ++ " = " ++ showFixable l2) (l1 `eq` l2)++-- a variable is either set to a value or bounded by other values+data R l a = R l |  Ri (Maybe l) (Set.Set (RS l a))  (Maybe l) (Set.Set (RS l a))+    deriving(Show)+type RS l a = Element (R l a) a++-- replace variables with UnionFind elements+prepareConstraints :: Ord v => C l v -> IO ([CL l (RS l v)], Map.Map v (RS l v))+prepareConstraints (C cseq) = f Map.empty (S.toList cseq) id [] where+    f m (c:cs) ar rs = do+        let h x mp = case Map.lookup x mp of+                Just v -> return (v,mp)+                Nothing -> do+                    v <- UF.new (Ri Nothing mempty Nothing mempty) x+                    return (v, Map.insert x v mp)+        case c of+            CL x op l -> do+                (x',m') <- h x m+                f m' cs id (ar (CL x' op l):rs)+            CV x op y -> do+                (x',m') <- h x m+                (y',m'') <- h y m'+                f m'' cs id (ar (CV x' op y'):rs)+            CLAnnotate s c -> f m (c:cs) (ar . CLAnnotate s) rs+    f m [] _ rs = return (rs,m)++check op x y = case op of+    OpEq -> x `eq` y+    OpLte -> x `lte` y+    OpGte -> y `lte` x++{-# NOINLINE solve #-}+solve :: (Fixable l, Show l, Show v, Ord v)+    => (String -> IO ())+    -> C l v+    -> IO (Map.Map v v,Map.Map v (Result l v))+solve putLog csp = do+    (pcs,varMap) <- prepareConstraints csp+    let procVar (CV x op y) = do+            xe <- UF.find x+            ye <- UF.find y+            doVar "" xe op ye+        procVar (CLAnnotate s CL {}) =  return ()+        procVar CL {} = return ()+        procVar (CLAnnotate s cr) =  putLog s >>  procVar cr+        doVar _ xe _ ye | xe == ye = return ()+        doVar lvl xe op ye = do+            putLog $ lvl ++ "Constraining: " ++ show (fromElement xe) ++ show op ++ show (fromElement ye)+            xw <- UF.getW xe+            yw <- UF.getW ye+            case (xw,yw) of+                (Ri xml xlb xmu xub,Ri yml ylb ymu yub) -> do+                    xub <- finds xub+                    xlb <- finds xlb+                    yub <- finds yub+                    ylb <- finds ylb+                    case op of+                        OpEq  ->  doEq lvl xe (Ri xml xlb xmu xub) ye (Ri yml ylb ymu yub)+                        OpLte -> doLte lvl xe (Ri xml xlb xmu xub) ye (Ri yml ylb ymu yub)+                        OpGte -> doLte lvl ye (Ri yml ylb ymu yub) xe (Ri xml xlb xmu xub)+                _ -> fail $ "UnionSolve: bad " ++  show (xw,yw)+        doEq lvl xe ~(Ri _ xlb _ xub) ye ~(Ri _ ylb _ yub) = do+            union const xe ye+            ne <- find xe+            nlb <- finds (xlb `Set.union` ylb)+            nub <- finds (yub `Set.union` xub)+            UF.putW ne (Ri Nothing nlb Nothing nub)+            checkRS lvl ne+        doLte lvl xe ~xw@(Ri xml xlb xmu xub) ye ~yw@(Ri yml ylb ymu yub) = do+            let done = UF.putW xe (Ri xml xlb xmu xub) >> UF.putW ye (Ri yml ylb ymu yub)+            if ye `Set.member` xub then done else do+            if xe `Set.member` ylb then done else do+            if ye `Set.member` xlb then doEq lvl xe xw ye yw else do+            if xe `Set.member` yub then doEq lvl xe xw ye yw else do+            UF.putW xe (Ri xml xlb xmu (Set.insert ye (xub `Set.union` yub)))+            UF.putW ye (Ri yml (Set.insert xe (ylb `Set.union` xlb)) ymu yub)+            checkRS lvl xe+            ye <- find ye+            checkRS lvl ye+        checkRS lvl ve = do+            Ri l lb h ub <- UF.getW ve+            lb <- finds lb+            ub <- finds ub+            UF.putW ve (Ri l (Set.delete ve lb) h (Set.delete ve ub))+            let equiv = lb `Set.intersection` ub+            forM_ (Set.toList equiv) $ doVar ('#':lvl) ve OpEq+        finds set = fmap Set.fromList $ mapM UF.find (Set.toList set)+    mapM_ procVar pcs++    let procLit (CL x op y) = do+            xe <- UF.find x+            doOp "" xe op y+        procLit (CLAnnotate s CV {}) =  return ()+        procLit CV {} = return ()+        procLit (CLAnnotate s cr) =  putLog s >>  procLit cr++        doOp lvl ve op l = do+            let doOp' ve op l = doOp ('-':lvl) ve op l+            putLog $ lvl ++ "Constraining: " ++ show (fromElement ve) ++ show op ++ show l+            vw <- getW ve+            case (op,vw) of+                (_,R c) | check op c l -> return ()+                        | otherwise -> fail $ "UnionSolve: constraint doesn't match (" ++ show c ++ show op ++ show l ++ ") when setting " ++ show (fromElement ve)+                (OpEq,Ri ml lb mu ub) | testBoundLT ml l && testBoundGT mu l -> do+                    updateW (const (R l)) ve+                    mapM_ (\v -> doOp' v OpLte l) (Set.toList lb)+                    mapM_ (\v -> doOp' v OpGte l) (Set.toList ub)+                (OpEq,_) | otherwise -> fail $ "UnionSolve: setValue " ++ show (fromElement ve,vw,l)+                (OpLte,Ri _ _ (Just n) _) | n `lte` l -> return ()+                (OpGte,Ri (Just n) _ _ _) | l `lte` n -> return ()+                (OpLte,Ri (Just n) _ _ _) | n `eq` l -> doOp' ve OpEq l+                (OpGte,Ri _ _ (Just n) _) | n `eq` l -> doOp' ve OpEq l+                (OpLte,Ri (Just n) _ _ _) | l `lte` n -> fail $ "UnionSolve: lower than lower bound  " ++ show (fromElement ve,vw,l,n)+                (OpGte,Ri _ _ (Just n) _) | n `lte` l -> fail $ "UnionSolve: higher than higher bound  " ++ show (fromElement ve,vw,l,n)+                (OpLte,Ri ml lb mu ub) -> do+                    let nv@(Just l') = mmeet (Just l) mu+                    doUpdate (Ri ml lb nv ub) ve+                    unless (nv `eq` mu) $+                        mapM_ (\v -> doOp' v OpLte l') (Set.toList lb)+                (OpGte,Ri ml lb mu ub) -> do+                    let nv@(Just l') = (mjoin (Just l) ml)+                    doUpdate (Ri nv lb mu ub) ve+                    unless (nv `eq` ml) $+                        mapM_ (\v -> doOp' v OpGte l') (Set.toList ub)+                -- _ -> fail $ "UnionSolve: bad " ++  show (fromElement ve,vw,op,l)+        testBoundLT Nothing _ = True+        testBoundLT (Just x) y = x `lte` y+        testBoundGT Nothing _ = True+        testBoundGT (Just x) y = y `lte` x+        checkRS (Ri (Just l) _ (Just u) _) xe | l `eq` u = do+            putLog $ "Boxed in value of " ++ show (fromElement xe) ++ " being set to " ++ show l+            doOp "&" xe OpEq l+        checkRS (Ri (Just l) _ (Just u) _) xe | u `lte` l = fail "checkRS: you crossed the streams"+        checkRS (Ri (Just l) _ _ _) xe  | isTop l = do+            putLog $ "Going up:   " ++ show (fromElement xe)+            doOp "&" xe OpEq l+        checkRS (Ri  _ _ (Just u) _) xe | isBottom u = do+            putLog $ "Going down: " ++ show (fromElement xe)+            doOp "&" xe OpEq u+        checkRS r xe = return ()+        doUpdate r xe = do+            updateW (const r) xe+            checkRS r xe+        mjoin Nothing b = b+        mjoin x Nothing = x+        mjoin (Just x) (Just y) = Just (join x y)+        mmeet Nothing b = b+        mmeet x Nothing = x+        mmeet (Just x) (Just y) = Just (meet x y)+    mapM_ procLit pcs+    rs <- flip mapM (Map.toList varMap) $ \ (a,e) -> do+        e <- find e+        w <- getW e+        rr <- case w of+            R v -> return (ResultJust (fromElement e) v)+            Ri ml lb mu ub -> do+                ub <- fmap (map fromElement . Set.toList) $ finds ub+                lb <- fmap (map fromElement . Set.toList) $ finds lb+                return (ResultBounded { resultRep = fromElement e, resultUB = mu, resultLB = ml, resultLBV = lb, resultUBV = ub })+        let aa = fromElement e+        return ((a,aa),(aa,rr))+    let (ma,mb) = unzip rs+    return (Map.fromList ma,Map.fromList mb)++-----------------------------------------------------------+-- The data type the results of the analysis are placed in.+-----------------------------------------------------------+data Result l a =+    ResultJust {+        resultRep :: a,+        resultValue :: l+    } |+    ResultBounded {+        resultRep :: a,+        resultLB :: Maybe l,+        resultUB :: Maybe l,+        resultLBV ::[a],+        resultUBV ::[a]+    }++instance (Show l, Show a) => Show (Result l a) where+    showsPrec _ x = (showResult x ++)++showResult (ResultJust a l) = show a ++ " = " ++ show l+showResult rb@ResultBounded {} = sb (resultLB rb) (resultLBV rb) ++ " <= " ++ show (resultRep rb) ++ " <= " ++ sb (resultUB rb) (resultUBV rb)  where+    sb Nothing n | null n = "_"+    sb (Just x) n | null n = show x+    sb Nothing n = show n+    sb (Just x) n = show x ++ show n++-------------------------------+-- useful instances for Fixable+-------------------------------++instance Ord n => Fixable (Set.Set n)  where+    isBottom = Set.null+    join a b = Set.union a b+    meet a b = Set.intersection a b+    lte a b = Set.isSubsetOf a b+    eq = (==)++instance Fixable Bool where+    isBottom x = not x+    isTop x = x+    join a b = a || b+    meet a b = a && b+    eq = (==)+    lte = (<=)++-- join is the maximum of integer values, as in this is the lattice of maximum, not the additive one.+instance Fixable Int where+    join a b = max a b+    meet a b = min a b+    lte = (<=)+    eq = (==)++instance (Fixable a,Fixable b) => Fixable (a,b) where+    isBottom (a,b) = isBottom a && isBottom b+    isTop (a,b) = isTop a && isTop b+    join (x,y) (x',y') = (join x x', join y y')+    meet (x,y) (x',y') = (meet x x', meet y y')+    lte (x,y) (x',y') = (lte x x' && lte y y')+    eq (x,y) (x',y') = (eq x x' && eq y y')++-- the maybe instance creates a new bottom of nothing. note that (Just bottom) is a distinct point.+instance Fixable a => Fixable (Maybe a) where+    isBottom Nothing = True+    isBottom _ = False+    isTop Nothing = False+    isTop (Just x) = isTop x+    join Nothing b = b+    join a Nothing = a+    join (Just a) (Just b) = Just (join a b)+    meet Nothing b = Nothing+    meet a Nothing = Nothing+    meet (Just a) (Just b) = Just (meet a b)+    lte Nothing _ = True+    lte _ Nothing = False+    lte (Just x) (Just y) = x `lte` y++-- the topped instance creates a new top of everything.+-- this is the opposite of the 'Maybe' instance+data Topped a = Only a | Top+    deriving(Eq,Ord,Show)++-- the maybe instance creates a new bottom of nothing. note that (Just bottom) is a distinct point.+instance Fixable a => Fixable (Topped a) where+    isBottom (Only x) = isBottom x+    isBottom Top = False+    isTop Top = True+    isTop _ = False+    meet Top b = b+    meet a Top = a+    meet (Only a) (Only b) = Only (meet a b)+    join Top b = Top+    join a Top = Top+    join (Only a) (Only b) = Only (join a b)+    eq Top Top = True+    eq (Only x) (Only y) = eq x y+    eq _ _ = False+    lte _ Top = True+    lte Top _ = False+    lte (Only x) (Only y) = x `lte` y
+ src/Util/UniqueMonad.hs view
@@ -0,0 +1,53 @@+module Util.UniqueMonad(UniqT,Uniq, runUniq, runUniqT, execUniq1, execUniq, execUniqT) where+++import GenUtil+import Data.Unique+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Identity+++instance UniqueProducer IO where+    newUniq = do+        u <- newUnique+        return $ hashUnique u++instance Monad m =>  UniqueProducer (UniqT m) where+    newUniq = UniqT $ do+        modify (+1)+        get++-- | Run the transformer version of the unique int generator.+runUniqT :: Monad m =>  UniqT m a -> Int -> m (a,Int)+runUniqT (UniqT sm) s  = runStateT sm s++-- | Run the bare version of the unique int generator.+runUniq :: Int -> Uniq a -> (a,Int)+runUniq x y = runIdentity $ runUniqT y x++-- | Execute the bare unique int generator starting with 1.+execUniq1 :: Uniq a -> a+execUniq1 x = fst $ runUniq 1 x++-- | Execute the bare unique int generator starting with the suplied number.+execUniq :: Int -> Uniq a -> a+execUniq st x = fst $ runUniq st x++-- | Execute the transformer version of the unique int generator starting with the suplied number.+execUniqT :: Monad m =>  Int -> UniqT m a -> m a+execUniqT s (UniqT sm)  = liftM fst $ runStateT sm s++instance (Monad m, Monad (t m), MonadTrans t, UniqueProducer m) => UniqueProducer (t m) where+    newUniq = lift newUniq++-- | Unique integer generator monad transformer.+newtype UniqT m a = UniqT (StateT Int m a)+    deriving(Monad,  MonadTrans, Functor, MonadFix, MonadPlus)++instance MonadReader s m => MonadReader s (UniqT m) where+    ask = UniqT $  ask+    local f (UniqT x) = UniqT $ local f x++-- | Unique integer generator monad.+type Uniq = UniqT Identity
+ src/Util/Util.hs view
@@ -0,0 +1,11 @@+module Util.Util(+    module Data.Monoid,+    module Data.List,+    module Data.Maybe,+    module Control.Monad+    ) where++import Data.Monoid+import Data.Maybe+import Data.List+import Control.Monad
+ src/Util/VarName.hs view
@@ -0,0 +1,72 @@+module Util.VarName(+    VarNameT(),+    VarName(),+    runVarNameT,+    runVarName,+    newName,+    subVarName,+    lookupName,+    maybeLookupName,+    newLookupName) where++import Control.Monad.State+import Control.Monad.Identity+import qualified Data.Map as Map++newtype VarNameT nc ni no m a = VarName (StateT (Map.Map ni no, Map.Map nc Int) m a)+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)++type VarName ni no a = VarNameT () ni no Identity a+++runVarNameT :: Monad m => VarNameT nc ni no m a -> m a+runVarNameT  (VarName sm) = evalStateT sm (Map.empty, Map.empty)++runVarName ::  VarName ni no a -> a+runVarName v = runIdentity $ runVarNameT v++subVarName ::  Monad m => VarNameT nc ni no m a -> VarNameT nc ni no m a+subVarName (VarName action) = VarName $ do+    x <- get+    r <- action+    put x+    return r+++newName :: (Ord ni, Ord nc,Monad m) => [no] -> nc -> ni -> VarNameT nc ni no m no+newName ns nc ni = VarName $ do+    (nim,ncm) <- get+    let no = ns!!i+        Just i = fmap (subtract 1) $ Map.lookup nc ncm'+        ncm' = Map.insertWith' (+) nc 1 ncm+    put (Map.insert ni no nim, ncm')+    return no++lookupName :: (Ord ni, Monad m,Show ni) => ni -> VarNameT nc ni no m no+lookupName t = VarName $ do+    (nim,_) <- get+    case Map.lookup t nim of+        Just x -> return x+        Nothing -> fail $ "lookupName not found: " ++ show t++maybeLookupName :: (Ord ni, Monad m,Show ni) => ni -> VarNameT nc ni no m (Maybe no)+maybeLookupName t = VarName $ do+    (nim,_) <- get+    case Map.lookup t nim of+        Just x -> return (Just x)+        Nothing -> return $ fail $ "lookupName not found: " ++ show t++newLookupName :: (Ord ni, Ord nc,Monad m) => [no] -> nc -> ni -> VarNameT nc ni no m no+newLookupName ns nc ni = VarName $ do+    (nim,ncm) <- get+    case Map.lookup ni nim of+        Just x -> return x+        Nothing -> do+            let no = ns!!i+                Just i = fmap (subtract 1) $ Map.lookup nc ncm'+                ncm' = Map.insertWith' (+) nc 1 ncm+            put (Map.insert ni no nim, ncm')+            return no+++
+ src/Util/YAML.hs view
@@ -0,0 +1,71 @@+module Util.YAML where++import Data.Char+import qualified Data.Map as M+import qualified Data.Set as S++data Node = Leaf String | List [Node] | Map [(String,Node)] | Null++class MapKey a where+    showMapKey :: a -> String++instance MapKey String where+    showMapKey s = s++class ToNode a where+    toNode :: a -> Node++instance ToNode Node where+    toNode x = x++instance ToNode String where+    toNode s = Leaf s++instance ToNode a => ToNode [a] where+    toNode ns = List (map toNode ns)++instance (MapKey k,ToNode a) => ToNode [(k,a)] where+    toNode ns = Map [ (showMapKey x,toNode y) | (x,y) <- ns ]++instance (MapKey k,ToNode b) => ToNode (M.Map k b) where+    toNode mp = Map [(showMapKey x, toNode y) | (x,y) <- M.toList mp]++instance ToNode a => ToNode (S.Set a) where+    toNode st = List $ map toNode (S.toList st)++instance ToNode a => ToNode (Maybe a) where+    toNode Nothing = Null+    toNode (Just x) = toNode x++instance (ToNode a,ToNode b) => ToNode (Either a b) where+    toNode (Left  x) = toNode x+    toNode (Right x) = toNode x++instance ToNode Bool where+    toNode True  = Leaf "true"+    toNode False = Leaf "false"++instance ToNode () where+    toNode () = Null++dumpNode :: Node -> String+dumpNode n = f False 0 n "\n" where+    f nn  i Null     = ns nn . showString "null"+    f nn  i (Leaf x) = ns nn . showString' x+    f nn i (List ns) = nl nn [ g i . showString "-" . f True (i + 1) n | n <- ns ]+    f nn i (Map  ns) = nl nn [ g i . showString x . showString ":" . f True (i + 1) y | (x,y) <- ns ]+    g i = showString $ replicate i ' '+    nl nn [] = id+    nl nn xs = (if nn then ('\n':) else id) . foldr1 (\x y -> x . showChar '\n' . y ) xs+    ns True  = showChar ' '+    ns False = id++showYAML :: ToNode a => a -> String+showYAML n = dumpNode (toNode n)++showString' x y = if all isGood x then x ++ y else '"':f x y where+    f [] y = '"':y+    f (x:xs) ys |  isQuoteGood x = x:f xs ys+                | otherwise  = '\\':x:f xs ys+    isGood x = isAlphaNum x || x `elem` "_-.@/"+    isQuoteGood x = isGood x || isSpace x || x `elem` "!@#$%^&*(){}/"
+ src/Version/Config.hs view
@@ -0,0 +1,14 @@+module Version.Config where++shortVersion = "0.8"+version = "0.8.0.1"+package = "ajhc"+libdir  = "/usr/local/lib"+datadir = "/usr/local/share"+host    = "x86_64-unknown-linux-gnu"+libraryInstall = "/usr/local/share/ajhc-0.8"+confDir = "/usr/local/etc/ajhc-0.8"+version_major = 0+version_minor = 8+version_patch = 0+revision = show $ (version_major*100 + version_minor :: Int)*100 + version_patch
+ src/Version/Version.hs view
@@ -0,0 +1,22 @@+module Version.Version(+    versionContext,+    versionSimple,+    versionString+    ) where+++import Data.Version+import System.Info+import qualified Data.ByteString.UTF8 as BS++import Version.Config+import RawFiles++{-# NOINLINE versionSimple #-}+versionSimple = concat [package, " ", version, " (", BS.toString shortchange_txt, ")"]++{-# NOINLINE versionString #-}+versionString = concat [versionSimple, "\n", "compiled by ",compilerName,"-",showVersion compilerVersion," on a ",arch," running ",os]++{-# NOINLINE versionContext #-}+versionContext = changelog
+ src/cbits/config.h view
@@ -0,0 +1,20 @@+#ifndef CONFIG_H+++#ifndef LITTLE_ENDIAN+#define	LITTLE_ENDIAN	1234+#endif++#ifndef BIG_ENDIAN+#define	BIG_ENDIAN	4321+#endif++#ifndef PDP_ENDIAN+#define	PDP_ENDIAN	3412+#endif++#ifndef BYTE_ORDER+#define BYTE_ORDER LITTLE_ENDIAN+#endif++#endif
+ src/cbits/lookup3.c view
@@ -0,0 +1,999 @@+/*+-------------------------------------------------------------------------------+lookup3.c, by Bob Jenkins, May 2006, Public Domain.++These are functions for producing 32-bit hashes for hash table lookup.+hashword(), hashlittle(), hashlittle2(), hashbig(), mix(), and final()+are externally useful functions.  Routines to test the hash are included+if SELF_TEST is defined.  You can use this free for any purpose.  It's in+the public domain.  It has no warranty.++You probably want to use hashlittle().  hashlittle() and hashbig()+hash byte arrays.  hashlittle() is is faster than hashbig() on+little-endian machines.  Intel and AMD are little-endian machines.+On second thought, you probably want hashlittle2(), which is identical to+hashlittle() except it returns two 32-bit hashes for the price of one.+You could implement hashbig2() if you wanted but I haven't bothered here.++If you want to find a hash of, say, exactly 7 integers, do+  a = i1;  b = i2;  c = i3;+  mix(a,b,c);+  a += i4; b += i5; c += i6;+  mix(a,b,c);+  a += i7;+  final(a,b,c);+then use c as the hash value.  If you have a variable length array of+4-byte integers to hash, use hashword().  If you have a byte array (like+a character string), use hashlittle().  If you have several byte arrays, or+a mix of things, see the comments above hashlittle().++Why is this so big?  I read 12 bytes at a time into 3 4-byte integers,+then mix those integers.  This is fast (you can do a lot more thorough+mixing with 12*3 instructions on 3 integers than you can with 3 instructions+on 1 byte), but shoehorning those bytes into integers efficiently is messy.+-------------------------------------------------------------------------------+*/+// #define SELF_TEST 0++#include <stdio.h>      /* defines printf for tests */+#include <time.h>       /* defines time_t for timings in the test */+#include <stdint.h>     /* defines uint32_t etc */+#include <sys/param.h>  /* attempt to define endianness */+#ifdef linux+# include <endian.h>    /* attempt to define endianness */+#endif++/*+ * My best guess at if you are big-endian or little-endian.  This may+ * need adjustment.+ */+#if (defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && \+     __BYTE_ORDER == __LITTLE_ENDIAN) || \+    (defined(i386) || defined(__i386__) || defined(__i486__) || \+     defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL))+# define HASH_LITTLE_ENDIAN 1+# define HASH_BIG_ENDIAN 0+#elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \+       __BYTE_ORDER == __BIG_ENDIAN) || \+      (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel))+# define HASH_LITTLE_ENDIAN 0+# define HASH_BIG_ENDIAN 1+#else+# define HASH_LITTLE_ENDIAN 0+# define HASH_BIG_ENDIAN 0+#endif++#define hashsize(n) ((uint32_t)1<<(n))+#define hashmask(n) (hashsize(n)-1)+#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k))))++/*+-------------------------------------------------------------------------------+mix -- mix 3 32-bit values reversibly.++This is reversible, so any information in (a,b,c) before mix() is+still in (a,b,c) after mix().++If four pairs of (a,b,c) inputs are run through mix(), or through+mix() in reverse, there are at least 32 bits of the output that+are sometimes the same for one pair and different for another pair.+This was tested for:+* pairs that differed by one bit, by two bits, in any combination+  of top bits of (a,b,c), or in any combination of bottom bits of+  (a,b,c).+* "differ" is defined as +, -, ^, or ~^.  For + and -, I transformed+  the output delta to a Gray code (a^(a>>1)) so a string of 1's (as+  is commonly produced by subtraction) look like a single 1-bit+  difference.+* the base values were pseudorandom, all zero but one bit set, or+  all zero plus a counter that starts at zero.++Some k values for my "a-=c; a^=rot(c,k); c+=b;" arrangement that+satisfy this are+    4  6  8 16 19  4+    9 15  3 18 27 15+   14  9  3  7 17  3+Well, "9 15 3 18 27 15" didn't quite get 32 bits diffing+for "differ" defined as + with a one-bit base and a two-bit delta.  I+used http://burtleburtle.net/bob/hash/avalanche.html to choose+the operations, constants, and arrangements of the variables.++This does not achieve avalanche.  There are input bits of (a,b,c)+that fail to affect some output bits of (a,b,c), especially of a.  The+most thoroughly mixed value is c, but it doesn't really even achieve+avalanche in c.++This allows some parallelism.  Read-after-writes are good at doubling+the number of bits affected, so the goal of mixing pulls in the opposite+direction as the goal of parallelism.  I did what I could.  Rotates+seem to cost as much as shifts on every machine I could lay my hands+on, and rotates are much kinder to the top and bottom bits, so I used+rotates.+-------------------------------------------------------------------------------+*/+#define mix(a,b,c) \+{ \+  a -= c;  a ^= rot(c, 4);  c += b; \+  b -= a;  b ^= rot(a, 6);  a += c; \+  c -= b;  c ^= rot(b, 8);  b += a; \+  a -= c;  a ^= rot(c,16);  c += b; \+  b -= a;  b ^= rot(a,19);  a += c; \+  c -= b;  c ^= rot(b, 4);  b += a; \+}++/*+-------------------------------------------------------------------------------+final -- final mixing of 3 32-bit values (a,b,c) into c++Pairs of (a,b,c) values differing in only a few bits will usually+produce values of c that look totally different.  This was tested for+* pairs that differed by one bit, by two bits, in any combination+  of top bits of (a,b,c), or in any combination of bottom bits of+  (a,b,c).+* "differ" is defined as +, -, ^, or ~^.  For + and -, I transformed+  the output delta to a Gray code (a^(a>>1)) so a string of 1's (as+  is commonly produced by subtraction) look like a single 1-bit+  difference.+* the base values were pseudorandom, all zero but one bit set, or+  all zero plus a counter that starts at zero.++These constants passed:+ 14 11 25 16 4 14 24+ 12 14 25 16 4 14 24+and these came close:+  4  8 15 26 3 22 24+ 10  8 15 26 3 22 24+ 11  8 15 26 3 22 24+-------------------------------------------------------------------------------+*/+#define final(a,b,c) \+{ \+  c ^= b; c -= rot(b,14); \+  a ^= c; a -= rot(c,11); \+  b ^= a; b -= rot(a,25); \+  c ^= b; c -= rot(b,16); \+  a ^= c; a -= rot(c,4);  \+  b ^= a; b -= rot(a,14); \+  c ^= b; c -= rot(b,24); \+}++/*+--------------------------------------------------------------------+ This works on all machines.  To be useful, it requires+ -- that the key be an array of uint32_t's, and+ -- that the length be the number of uint32_t's in the key++ The function hashword() is identical to hashlittle() on little-endian+ machines, and identical to hashbig() on big-endian machines,+ except that the length has to be measured in uint32_ts rather than in+ bytes.  hashlittle() is more complicated than hashword() only because+ hashlittle() has to dance around fitting the key bytes into registers.+--------------------------------------------------------------------+*/+uint32_t hashword(+const uint32_t *k,                   /* the key, an array of uint32_t values */+size_t          length,               /* the length of the key, in uint32_ts */+uint32_t        initval)         /* the previous hash, or an arbitrary value */+{+  uint32_t a,b,c;++  /* Set up the internal state */+  a = b = c = 0xdeadbeef + (((uint32_t)length)<<2) + initval;++  /*------------------------------------------------- handle most of the key */+  while (length > 3)+  {+    a += k[0];+    b += k[1];+    c += k[2];+    mix(a,b,c);+    length -= 3;+    k += 3;+  }++  /*------------------------------------------- handle the last 3 uint32_t's */+  switch(length)                     /* all the case statements fall through */+  {+  case 3 : c+=k[2];+  case 2 : b+=k[1];+  case 1 : a+=k[0];+    final(a,b,c);+  case 0:     /* case 0: nothing left to add */+    break;+  }+  /*------------------------------------------------------ report the result */+  return c;+}++/*+--------------------------------------------------------------------+hashword2() -- same as hashword(), but take two seeds and return two+32-bit values.  pc and pb must both be nonnull, and *pc and *pb must+both be initialized with seeds.  If you pass in (*pb)==0, the output+(*pc) will be the same as the return value from hashword().+--------------------------------------------------------------------+*/+void hashword2 (+const uint32_t *k,                   /* the key, an array of uint32_t values */+size_t          length,               /* the length of the key, in uint32_ts */+uint32_t       *pc,                      /* IN: seed OUT: primary hash value */+uint32_t       *pb)               /* IN: more seed OUT: secondary hash value */+{+  uint32_t a,b,c;++  /* Set up the internal state */+  a = b = c = 0xdeadbeef + ((uint32_t)(length<<2)) + *pc;+  c += *pb;++  /*------------------------------------------------- handle most of the key */+  while (length > 3)+  {+    a += k[0];+    b += k[1];+    c += k[2];+    mix(a,b,c);+    length -= 3;+    k += 3;+  }++  /*------------------------------------------- handle the last 3 uint32_t's */+  switch(length)                     /* all the case statements fall through */+  {+  case 3 : c+=k[2];+  case 2 : b+=k[1];+  case 1 : a+=k[0];+    final(a,b,c);+  case 0:     /* case 0: nothing left to add */+    break;+  }+  /*------------------------------------------------------ report the result */+  *pc=c; *pb=b;+}++/*+-------------------------------------------------------------------------------+hashlittle() -- hash a variable-length key into a 32-bit value+  k       : the key (the unaligned variable-length array of bytes)+  length  : the length of the key, counting by bytes+  initval : can be any 4-byte value+Returns a 32-bit value.  Every bit of the key affects every bit of+the return value.  Two keys differing by one or two bits will have+totally different hash values.++The best hash table sizes are powers of 2.  There is no need to do+mod a prime (mod is sooo slow!).  If you need less than 32 bits,+use a bitmask.  For example, if you need only 10 bits, do+  h = (h & hashmask(10));+In which case, the hash table should have hashsize(10) elements.++If you are hashing n strings (uint8_t **)k, do it like this:+  for (i=0, h=0; i<n; ++i) h = hashlittle( k[i], len[i], h);++By Bob Jenkins, 2006.  bob_jenkins@burtleburtle.net.  You may use this+code any way you wish, private, educational, or commercial.  It's free.++Use for hash table lookup, or anything where one collision in 2^^32 is+acceptable.  Do NOT use for cryptographic purposes.+-------------------------------------------------------------------------------+*/++uint32_t hashlittle( const void *key, size_t length, uint32_t initval)+{+  uint32_t a,b,c;                                          /* internal state */+  union { const void *ptr; size_t i; } u;     /* needed for Mac Powerbook G4 */++  /* Set up the internal state */+  a = b = c = 0xdeadbeef + ((uint32_t)length) + initval;++  u.ptr = key;+  if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) {+    const uint32_t *k = (const uint32_t *)key;         /* read 32-bit chunks */+#ifdef VALGRIND+    const uint8_t  *k8;+#endif++    /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */+    while (length > 12)+    {+      a += k[0];+      b += k[1];+      c += k[2];+      mix(a,b,c);+      length -= 12;+      k += 3;+    }++    /*----------------------------- handle the last (probably partial) block */+    /*+     * "k[2]&0xffffff" actually reads beyond the end of the string, but+     * then masks off the part it's not allowed to read.  Because the+     * string is aligned, the masked-off tail is in the same word as the+     * rest of the string.  Every machine with memory protection I've seen+     * does it on word boundaries, so is OK with this.  But VALGRIND will+     * still catch it and complain.  The masking trick does make the hash+     * noticably faster for short strings (like English words).+     */+#ifndef VALGRIND++    switch(length)+    {+    case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;+    case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break;+    case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break;+    case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break;+    case 8 : b+=k[1]; a+=k[0]; break;+    case 7 : b+=k[1]&0xffffff; a+=k[0]; break;+    case 6 : b+=k[1]&0xffff; a+=k[0]; break;+    case 5 : b+=k[1]&0xff; a+=k[0]; break;+    case 4 : a+=k[0]; break;+    case 3 : a+=k[0]&0xffffff; break;+    case 2 : a+=k[0]&0xffff; break;+    case 1 : a+=k[0]&0xff; break;+    case 0 : return c;              /* zero length strings require no mixing */+    }++#else /* make valgrind happy */++    k8 = (const uint8_t *)k;+    switch(length)+    {+    case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;+    case 11: c+=((uint32_t)k8[10])<<16;  /* fall through */+    case 10: c+=((uint32_t)k8[9])<<8;    /* fall through */+    case 9 : c+=k8[8];                   /* fall through */+    case 8 : b+=k[1]; a+=k[0]; break;+    case 7 : b+=((uint32_t)k8[6])<<16;   /* fall through */+    case 6 : b+=((uint32_t)k8[5])<<8;    /* fall through */+    case 5 : b+=k8[4];                   /* fall through */+    case 4 : a+=k[0]; break;+    case 3 : a+=((uint32_t)k8[2])<<16;   /* fall through */+    case 2 : a+=((uint32_t)k8[1])<<8;    /* fall through */+    case 1 : a+=k8[0]; break;+    case 0 : return c;+    }++#endif /* !valgrind */++  } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) {+    const uint16_t *k = (const uint16_t *)key;         /* read 16-bit chunks */+    const uint8_t  *k8;++    /*--------------- all but last block: aligned reads and different mixing */+    while (length > 12)+    {+      a += k[0] + (((uint32_t)k[1])<<16);+      b += k[2] + (((uint32_t)k[3])<<16);+      c += k[4] + (((uint32_t)k[5])<<16);+      mix(a,b,c);+      length -= 12;+      k += 6;+    }++    /*----------------------------- handle the last (probably partial) block */+    k8 = (const uint8_t *)k;+    switch(length)+    {+    case 12: c+=k[4]+(((uint32_t)k[5])<<16);+             b+=k[2]+(((uint32_t)k[3])<<16);+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 11: c+=((uint32_t)k8[10])<<16;     /* fall through */+    case 10: c+=k[4];+             b+=k[2]+(((uint32_t)k[3])<<16);+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 9 : c+=k8[8];                      /* fall through */+    case 8 : b+=k[2]+(((uint32_t)k[3])<<16);+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 7 : b+=((uint32_t)k8[6])<<16;      /* fall through */+    case 6 : b+=k[2];+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 5 : b+=k8[4];                      /* fall through */+    case 4 : a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 3 : a+=((uint32_t)k8[2])<<16;      /* fall through */+    case 2 : a+=k[0];+             break;+    case 1 : a+=k8[0];+             break;+    case 0 : return c;                     /* zero length requires no mixing */+    }++  } else {                        /* need to read the key one byte at a time */+    const uint8_t *k = (const uint8_t *)key;++    /*--------------- all but the last block: affect some 32 bits of (a,b,c) */+    while (length > 12)+    {+      a += k[0];+      a += ((uint32_t)k[1])<<8;+      a += ((uint32_t)k[2])<<16;+      a += ((uint32_t)k[3])<<24;+      b += k[4];+      b += ((uint32_t)k[5])<<8;+      b += ((uint32_t)k[6])<<16;+      b += ((uint32_t)k[7])<<24;+      c += k[8];+      c += ((uint32_t)k[9])<<8;+      c += ((uint32_t)k[10])<<16;+      c += ((uint32_t)k[11])<<24;+      mix(a,b,c);+      length -= 12;+      k += 12;+    }++    /*-------------------------------- last block: affect all 32 bits of (c) */+    switch(length)                   /* all the case statements fall through */+    {+    case 12: c+=((uint32_t)k[11])<<24;+    case 11: c+=((uint32_t)k[10])<<16;+    case 10: c+=((uint32_t)k[9])<<8;+    case 9 : c+=k[8];+    case 8 : b+=((uint32_t)k[7])<<24;+    case 7 : b+=((uint32_t)k[6])<<16;+    case 6 : b+=((uint32_t)k[5])<<8;+    case 5 : b+=k[4];+    case 4 : a+=((uint32_t)k[3])<<24;+    case 3 : a+=((uint32_t)k[2])<<16;+    case 2 : a+=((uint32_t)k[1])<<8;+    case 1 : a+=k[0];+             break;+    case 0 : return c;+    }+  }++  final(a,b,c);+  return c;+}++/*+ * hashlittle2: return 2 32-bit hash values+ *+ * This is identical to hashlittle(), except it returns two 32-bit hash+ * values instead of just one.  This is good enough for hash table+ * lookup with 2^^64 buckets, or if you want a second hash if you're not+ * happy with the first, or if you want a probably-unique 64-bit ID for+ * the key.  *pc is better mixed than *pb, so use *pc first.  If you want+ * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)".+ */+void hashlittle2(+  const void *key,       /* the key to hash */+  size_t      length,    /* length of the key */+  uint32_t   *pc,        /* IN: primary initval, OUT: primary hash */+  uint32_t   *pb)        /* IN: secondary initval, OUT: secondary hash */+{+  uint32_t a,b,c;                                          /* internal state */+  union { const void *ptr; size_t i; } u;     /* needed for Mac Powerbook G4 */++  /* Set up the internal state */+  a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc;+  c += *pb;++  u.ptr = key;+  if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) {+    const uint32_t *k = (const uint32_t *)key;         /* read 32-bit chunks */+#ifdef VALGRIND+    const uint8_t  *k8;+#endif++    /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */+    while (length > 12)+    {+      a += k[0];+      b += k[1];+      c += k[2];+      mix(a,b,c);+      length -= 12;+      k += 3;+    }++    /*----------------------------- handle the last (probably partial) block */+    /*+     * "k[2]&0xffffff" actually reads beyond the end of the string, but+     * then masks off the part it's not allowed to read.  Because the+     * string is aligned, the masked-off tail is in the same word as the+     * rest of the string.  Every machine with memory protection I've seen+     * does it on word boundaries, so is OK with this.  But VALGRIND will+     * still catch it and complain.  The masking trick does make the hash+     * noticably faster for short strings (like English words).+     */+#ifndef VALGRIND++    switch(length)+    {+    case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;+    case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break;+    case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break;+    case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break;+    case 8 : b+=k[1]; a+=k[0]; break;+    case 7 : b+=k[1]&0xffffff; a+=k[0]; break;+    case 6 : b+=k[1]&0xffff; a+=k[0]; break;+    case 5 : b+=k[1]&0xff; a+=k[0]; break;+    case 4 : a+=k[0]; break;+    case 3 : a+=k[0]&0xffffff; break;+    case 2 : a+=k[0]&0xffff; break;+    case 1 : a+=k[0]&0xff; break;+    case 0 : *pc=c; *pb=b; return;  /* zero length strings require no mixing */+    }++#else /* make valgrind happy */++    k8 = (const uint8_t *)k;+    switch(length)+    {+    case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;+    case 11: c+=((uint32_t)k8[10])<<16;  /* fall through */+    case 10: c+=((uint32_t)k8[9])<<8;    /* fall through */+    case 9 : c+=k8[8];                   /* fall through */+    case 8 : b+=k[1]; a+=k[0]; break;+    case 7 : b+=((uint32_t)k8[6])<<16;   /* fall through */+    case 6 : b+=((uint32_t)k8[5])<<8;    /* fall through */+    case 5 : b+=k8[4];                   /* fall through */+    case 4 : a+=k[0]; break;+    case 3 : a+=((uint32_t)k8[2])<<16;   /* fall through */+    case 2 : a+=((uint32_t)k8[1])<<8;    /* fall through */+    case 1 : a+=k8[0]; break;+    case 0 : *pc=c; *pb=b; return;  /* zero length strings require no mixing */+    }++#endif /* !valgrind */++  } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) {+    const uint16_t *k = (const uint16_t *)key;         /* read 16-bit chunks */+    const uint8_t  *k8;++    /*--------------- all but last block: aligned reads and different mixing */+    while (length > 12)+    {+      a += k[0] + (((uint32_t)k[1])<<16);+      b += k[2] + (((uint32_t)k[3])<<16);+      c += k[4] + (((uint32_t)k[5])<<16);+      mix(a,b,c);+      length -= 12;+      k += 6;+    }++    /*----------------------------- handle the last (probably partial) block */+    k8 = (const uint8_t *)k;+    switch(length)+    {+    case 12: c+=k[4]+(((uint32_t)k[5])<<16);+             b+=k[2]+(((uint32_t)k[3])<<16);+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 11: c+=((uint32_t)k8[10])<<16;     /* fall through */+    case 10: c+=k[4];+             b+=k[2]+(((uint32_t)k[3])<<16);+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 9 : c+=k8[8];                      /* fall through */+    case 8 : b+=k[2]+(((uint32_t)k[3])<<16);+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 7 : b+=((uint32_t)k8[6])<<16;      /* fall through */+    case 6 : b+=k[2];+             a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 5 : b+=k8[4];                      /* fall through */+    case 4 : a+=k[0]+(((uint32_t)k[1])<<16);+             break;+    case 3 : a+=((uint32_t)k8[2])<<16;      /* fall through */+    case 2 : a+=k[0];+             break;+    case 1 : a+=k8[0];+             break;+    case 0 : *pc=c; *pb=b; return;  /* zero length strings require no mixing */+    }++  } else {                        /* need to read the key one byte at a time */+    const uint8_t *k = (const uint8_t *)key;++    /*--------------- all but the last block: affect some 32 bits of (a,b,c) */+    while (length > 12)+    {+      a += k[0];+      a += ((uint32_t)k[1])<<8;+      a += ((uint32_t)k[2])<<16;+      a += ((uint32_t)k[3])<<24;+      b += k[4];+      b += ((uint32_t)k[5])<<8;+      b += ((uint32_t)k[6])<<16;+      b += ((uint32_t)k[7])<<24;+      c += k[8];+      c += ((uint32_t)k[9])<<8;+      c += ((uint32_t)k[10])<<16;+      c += ((uint32_t)k[11])<<24;+      mix(a,b,c);+      length -= 12;+      k += 12;+    }++    /*-------------------------------- last block: affect all 32 bits of (c) */+    switch(length)                   /* all the case statements fall through */+    {+    case 12: c+=((uint32_t)k[11])<<24;+    case 11: c+=((uint32_t)k[10])<<16;+    case 10: c+=((uint32_t)k[9])<<8;+    case 9 : c+=k[8];+    case 8 : b+=((uint32_t)k[7])<<24;+    case 7 : b+=((uint32_t)k[6])<<16;+    case 6 : b+=((uint32_t)k[5])<<8;+    case 5 : b+=k[4];+    case 4 : a+=((uint32_t)k[3])<<24;+    case 3 : a+=((uint32_t)k[2])<<16;+    case 2 : a+=((uint32_t)k[1])<<8;+    case 1 : a+=k[0];+             break;+    case 0 : *pc=c; *pb=b; return;  /* zero length strings require no mixing */+    }+  }++  final(a,b,c);+  *pc=c; *pb=b;+}++/*+ * hashbig():+ * This is the same as hashword() on big-endian machines.  It is different+ * from hashlittle() on all machines.  hashbig() takes advantage of+ * big-endian byte ordering.+ */+uint32_t hashbig( const void *key, size_t length, uint32_t initval)+{+  uint32_t a,b,c;+  union { const void *ptr; size_t i; } u; /* to cast key to (size_t) happily */++  /* Set up the internal state */+  a = b = c = 0xdeadbeef + ((uint32_t)length) + initval;++  u.ptr = key;+  if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) {+    const uint32_t *k = (const uint32_t *)key;         /* read 32-bit chunks */+#ifdef VALGRIND+    const uint8_t  *k8;+#endif++    /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */+    while (length > 12)+    {+      a += k[0];+      b += k[1];+      c += k[2];+      mix(a,b,c);+      length -= 12;+      k += 3;+    }++    /*----------------------------- handle the last (probably partial) block */+    /*+     * "k[2]<<8" actually reads beyond the end of the string, but+     * then shifts out the part it's not allowed to read.  Because the+     * string is aligned, the illegal read is in the same word as the+     * rest of the string.  Every machine with memory protection I've seen+     * does it on word boundaries, so is OK with this.  But VALGRIND will+     * still catch it and complain.  The masking trick does make the hash+     * noticably faster for short strings (like English words).+     */+#ifndef VALGRIND++    switch(length)+    {+    case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;+    case 11: c+=k[2]&0xffffff00; b+=k[1]; a+=k[0]; break;+    case 10: c+=k[2]&0xffff0000; b+=k[1]; a+=k[0]; break;+    case 9 : c+=k[2]&0xff000000; b+=k[1]; a+=k[0]; break;+    case 8 : b+=k[1]; a+=k[0]; break;+    case 7 : b+=k[1]&0xffffff00; a+=k[0]; break;+    case 6 : b+=k[1]&0xffff0000; a+=k[0]; break;+    case 5 : b+=k[1]&0xff000000; a+=k[0]; break;+    case 4 : a+=k[0]; break;+    case 3 : a+=k[0]&0xffffff00; break;+    case 2 : a+=k[0]&0xffff0000; break;+    case 1 : a+=k[0]&0xff000000; break;+    case 0 : return c;              /* zero length strings require no mixing */+    }++#else  /* make valgrind happy */++    k8 = (const uint8_t *)k;+    switch(length)                   /* all the case statements fall through */+    {+    case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;+    case 11: c+=((uint32_t)k8[10])<<8;  /* fall through */+    case 10: c+=((uint32_t)k8[9])<<16;  /* fall through */+    case 9 : c+=((uint32_t)k8[8])<<24;  /* fall through */+    case 8 : b+=k[1]; a+=k[0]; break;+    case 7 : b+=((uint32_t)k8[6])<<8;   /* fall through */+    case 6 : b+=((uint32_t)k8[5])<<16;  /* fall through */+    case 5 : b+=((uint32_t)k8[4])<<24;  /* fall through */+    case 4 : a+=k[0]; break;+    case 3 : a+=((uint32_t)k8[2])<<8;   /* fall through */+    case 2 : a+=((uint32_t)k8[1])<<16;  /* fall through */+    case 1 : a+=((uint32_t)k8[0])<<24; break;+    case 0 : return c;+    }++#endif /* !VALGRIND */++  } else {                        /* need to read the key one byte at a time */+    const uint8_t *k = (const uint8_t *)key;++    /*--------------- all but the last block: affect some 32 bits of (a,b,c) */+    while (length > 12)+    {+      a += ((uint32_t)k[0])<<24;+      a += ((uint32_t)k[1])<<16;+      a += ((uint32_t)k[2])<<8;+      a += ((uint32_t)k[3]);+      b += ((uint32_t)k[4])<<24;+      b += ((uint32_t)k[5])<<16;+      b += ((uint32_t)k[6])<<8;+      b += ((uint32_t)k[7]);+      c += ((uint32_t)k[8])<<24;+      c += ((uint32_t)k[9])<<16;+      c += ((uint32_t)k[10])<<8;+      c += ((uint32_t)k[11]);+      mix(a,b,c);+      length -= 12;+      k += 12;+    }++    /*-------------------------------- last block: affect all 32 bits of (c) */+    switch(length)                   /* all the case statements fall through */+    {+    case 12: c+=k[11];+    case 11: c+=((uint32_t)k[10])<<8;+    case 10: c+=((uint32_t)k[9])<<16;+    case 9 : c+=((uint32_t)k[8])<<24;+    case 8 : b+=k[7];+    case 7 : b+=((uint32_t)k[6])<<8;+    case 6 : b+=((uint32_t)k[5])<<16;+    case 5 : b+=((uint32_t)k[4])<<24;+    case 4 : a+=k[3];+    case 3 : a+=((uint32_t)k[2])<<8;+    case 2 : a+=((uint32_t)k[1])<<16;+    case 1 : a+=((uint32_t)k[0])<<24;+             break;+    case 0 : return c;+    }+  }++  final(a,b,c);+  return c;+}++#ifdef SELF_TEST++/* used for timings */+void driver1()+{+  uint8_t buf[256];+  uint32_t i;+  uint32_t h=0;+  time_t a,z;++  time(&a);+  for (i=0; i<256; ++i) buf[i] = 'x';+  for (i=0; i<1; ++i)+  {+    h = hashlittle(&buf[0],1,h);+  }+  time(&z);+  if (z-a > 0) printf("time %d %.8x\n", z-a, h);+}++/* check that every input bit changes every output bit half the time */+#define HASHSTATE 1+#define HASHLEN   1+#define MAXPAIR 60+#define MAXLEN  70+void driver2()+{+  uint8_t qa[MAXLEN+1], qb[MAXLEN+2], *a = &qa[0], *b = &qb[1];+  uint32_t c[HASHSTATE], d[HASHSTATE], i=0, j=0, k, l, m=0, z;+  uint32_t e[HASHSTATE],f[HASHSTATE],g[HASHSTATE],h[HASHSTATE];+  uint32_t x[HASHSTATE],y[HASHSTATE];+  uint32_t hlen;++  printf("No more than %d trials should ever be needed \n",MAXPAIR/2);+  for (hlen=0; hlen < MAXLEN; ++hlen)+  {+    z=0;+    for (i=0; i<hlen; ++i)  /*----------------------- for each input byte, */+    {+      for (j=0; j<8; ++j)   /*------------------------ for each input bit, */+      {+	for (m=1; m<8; ++m) /*------------ for serveral possible initvals, */+	{+	  for (l=0; l<HASHSTATE; ++l)+	    e[l]=f[l]=g[l]=h[l]=x[l]=y[l]=~((uint32_t)0);++      	  /*---- check that every output bit is affected by that input bit */+	  for (k=0; k<MAXPAIR; k+=2)+	  {+	    uint32_t finished=1;+	    /* keys have one bit different */+	    for (l=0; l<hlen+1; ++l) {a[l] = b[l] = (uint8_t)0;}+	    /* have a and b be two keys differing in only one bit */+	    a[i] ^= (k<<j);+	    a[i] ^= (k>>(8-j));+	     c[0] = hashlittle(a, hlen, m);+	    b[i] ^= ((k+1)<<j);+	    b[i] ^= ((k+1)>>(8-j));+	     d[0] = hashlittle(b, hlen, m);+	    /* check every bit is 1, 0, set, and not set at least once */+	    for (l=0; l<HASHSTATE; ++l)+	    {+	      e[l] &= (c[l]^d[l]);+	      f[l] &= ~(c[l]^d[l]);+	      g[l] &= c[l];+	      h[l] &= ~c[l];+	      x[l] &= d[l];+	      y[l] &= ~d[l];+	      if (e[l]|f[l]|g[l]|h[l]|x[l]|y[l]) finished=0;+	    }+	    if (finished) break;+	  }+	  if (k>z) z=k;+	  if (k==MAXPAIR)+	  {+	     printf("Some bit didn't change: ");+	     printf("%.8x %.8x %.8x %.8x %.8x %.8x  ",+	            e[0],f[0],g[0],h[0],x[0],y[0]);+	     printf("i %d j %d m %d len %d\n", i, j, m, hlen);+	  }+	  if (z==MAXPAIR) goto done;+	}+      }+    }+   done:+    if (z < MAXPAIR)+    {+      printf("Mix success  %2d bytes  %2d initvals  ",i,m);+      printf("required  %d  trials\n", z/2);+    }+  }+  printf("\n");+}++/* Check for reading beyond the end of the buffer and alignment problems */+void driver3()+{+  uint8_t buf[MAXLEN+20], *b;+  uint32_t len;+  uint8_t q[] = "This is the time for all good men to come to the aid of their country...";+  uint32_t h;+  uint8_t qq[] = "xThis is the time for all good men to come to the aid of their country...";+  uint32_t i;+  uint8_t qqq[] = "xxThis is the time for all good men to come to the aid of their country...";+  uint32_t j;+  uint8_t qqqq[] = "xxxThis is the time for all good men to come to the aid of their country...";+  uint32_t ref,x,y;+  uint8_t *p;++  printf("Endianness.  These lines should all be the same (for values filled in):\n");+  printf("%.8x                            %.8x                            %.8x\n",+         hashword((const uint32_t *)q, (sizeof(q)-1)/4, 13),+         hashword((const uint32_t *)q, (sizeof(q)-5)/4, 13),+         hashword((const uint32_t *)q, (sizeof(q)-9)/4, 13));+  p = q;+  printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",+         hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13),+         hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13),+         hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13),+         hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13),+         hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13),+         hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13));+  p = &qq[1];+  printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",+         hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13),+         hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13),+         hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13),+         hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13),+         hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13),+         hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13));+  p = &qqq[2];+  printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",+         hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13),+         hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13),+         hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13),+         hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13),+         hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13),+         hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13));+  p = &qqqq[3];+  printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",+         hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13),+         hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13),+         hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13),+         hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13),+         hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13),+         hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13));+  printf("\n");++  /* check that hashlittle2 and hashlittle produce the same results */+  i=47; j=0;+  hashlittle2(q, sizeof(q), &i, &j);+  if (hashlittle(q, sizeof(q), 47) != i)+    printf("hashlittle2 and hashlittle mismatch\n");++  /* check that hashword2 and hashword produce the same results */+  len = 0xdeadbeef;+  i=47, j=0;+  hashword2(&len, 1, &i, &j);+  if (hashword(&len, 1, 47) != i)+    printf("hashword2 and hashword mismatch %x %x\n",+	   i, hashword(&len, 1, 47));++  /* check hashlittle doesn't read before or after the ends of the string */+  for (h=0, b=buf+1; h<8; ++h, ++b)+  {+    for (i=0; i<MAXLEN; ++i)+    {+      len = i;+      for (j=0; j<i; ++j) *(b+j)=0;++      /* these should all be equal */+      ref = hashlittle(b, len, (uint32_t)1);+      *(b+i)=(uint8_t)~0;+      *(b-1)=(uint8_t)~0;+      x = hashlittle(b, len, (uint32_t)1);+      y = hashlittle(b, len, (uint32_t)1);+      if ((ref != x) || (ref != y))+      {+	printf("alignment error: %.8x %.8x %.8x %d %d\n",ref,x,y,+               h, i);+      }+    }+  }+}++/* check for problems with nulls */+ void driver4()+{+  uint8_t buf[1];+  uint32_t h,i,state[HASHSTATE];++  buf[0] = ~0;+  for (i=0; i<HASHSTATE; ++i) state[i] = 1;+  printf("These should all be different\n");+  for (i=0, h=0; i<8; ++i)+  {+    h = hashlittle(buf, 0, h);+    printf("%2ld  0-byte strings, hash is  %.8x\n", i, h);+  }+}++void driver5()+{+  uint32_t b,c;+  b=0, c=0, hashlittle2("", 0, &c, &b);+  printf("hash is %.8lx %.8lx\n", c, b);   /* deadbeef deadbeef */+  b=0xdeadbeef, c=0, hashlittle2("", 0, &c, &b);+  printf("hash is %.8lx %.8lx\n", c, b);   /* bd5b7dde deadbeef */+  b=0xdeadbeef, c=0xdeadbeef, hashlittle2("", 0, &c, &b);+  printf("hash is %.8lx %.8lx\n", c, b);   /* 9c093ccd bd5b7dde */+  b=0, c=0, hashlittle2("Four score and seven years ago", 30, &c, &b);+  printf("hash is %.8lx %.8lx\n", c, b);   /* 17770551 ce7226e6 */+  b=1, c=0, hashlittle2("Four score and seven years ago", 30, &c, &b);+  printf("hash is %.8lx %.8lx\n", c, b);   /* e3607cae bd371de4 */+  b=0, c=1, hashlittle2("Four score and seven years ago", 30, &c, &b);+  printf("hash is %.8lx %.8lx\n", c, b);   /* cd628161 6cbea4b3 */+  c = hashlittle("Four score and seven years ago", 30, 0);+  printf("hash is %.8lx\n", c);   /* 17770551 */+  c = hashlittle("Four score and seven years ago", 30, 1);+  printf("hash is %.8lx\n", c);   /* cd628161 */+}++int main()+{+  driver1();   /* test that the key is hashed: used for timings */+  driver2();   /* test that whole key is hashed thoroughly */+  driver3();   /* test that nothing but the key is hashed */+  driver4();   /* test hashing multiple buffers (all buffers are null) */+  driver5();   /* test the hash against known vectors */+  return 1;+}++#endif  /* SELF_TEST */
+ src/cbits/md5sum.c view
@@ -0,0 +1,384 @@++/*+ *+  Copyright (C) 1999, 2002 Aladdin Enterprises.  All rights reserved.++  This software is provided 'as-is', without any express or implied+  warranty.  In no event will the authors be held liable for any damages+  arising from the use of this software.++  Permission is granted to anyone to use this software for any purpose,+  including commercial applications, and to alter it and redistribute it+  freely, subject to the following restrictions:++  1. The origin of this software must not be misrepresented; you must not+     claim that you wrote the original software. If you use this software+     in a product, an acknowledgment in the product documentation would be+     appreciated but is not required.+  2. Altered source versions must be plainly marked as such, and must not be+     misrepresented as being the original software.+  3. This notice may not be removed or altered from any source distribution.++  L. Peter Deutsch+  ghost@aladdin.com++ */+++#include "config.h"+#include <stdint.h>++++typedef uint8_t md5_byte_t; /* 8-bit byte */+typedef uint32_t md5_word_t; /* 32-bit word */++/* Define the state of the MD5 Algorithm. */+typedef struct md5_state_s {+    md5_word_t count[2];	/* message length in bits, lsw first */+    md5_word_t abcd[4];		/* digest buffer */+    md5_byte_t buf[64];		/* accumulate block */+} md5_state_t;+++int get_md5_statesize(void) { return sizeof(md5_state_t); }++/* Initialize the algorithm. */+void md5_init(md5_state_t *pms);++/* Append a string to the message. */+void md5_append(md5_state_t *pms, const md5_byte_t *data, int nbytes);++/* Finish the message and return the digest. */+void md5_finish(md5_state_t *pms, md5_byte_t digest[16]);+++#include <string.h>+++#define T_MASK ((md5_word_t)~0)+#define T1 /* 0xd76aa478 */ (T_MASK ^ 0x28955b87)+#define T2 /* 0xe8c7b756 */ (T_MASK ^ 0x173848a9)+#define T3    0x242070db+#define T4 /* 0xc1bdceee */ (T_MASK ^ 0x3e423111)+#define T5 /* 0xf57c0faf */ (T_MASK ^ 0x0a83f050)+#define T6    0x4787c62a+#define T7 /* 0xa8304613 */ (T_MASK ^ 0x57cfb9ec)+#define T8 /* 0xfd469501 */ (T_MASK ^ 0x02b96afe)+#define T9    0x698098d8+#define T10 /* 0x8b44f7af */ (T_MASK ^ 0x74bb0850)+#define T11 /* 0xffff5bb1 */ (T_MASK ^ 0x0000a44e)+#define T12 /* 0x895cd7be */ (T_MASK ^ 0x76a32841)+#define T13    0x6b901122+#define T14 /* 0xfd987193 */ (T_MASK ^ 0x02678e6c)+#define T15 /* 0xa679438e */ (T_MASK ^ 0x5986bc71)+#define T16    0x49b40821+#define T17 /* 0xf61e2562 */ (T_MASK ^ 0x09e1da9d)+#define T18 /* 0xc040b340 */ (T_MASK ^ 0x3fbf4cbf)+#define T19    0x265e5a51+#define T20 /* 0xe9b6c7aa */ (T_MASK ^ 0x16493855)+#define T21 /* 0xd62f105d */ (T_MASK ^ 0x29d0efa2)+#define T22    0x02441453+#define T23 /* 0xd8a1e681 */ (T_MASK ^ 0x275e197e)+#define T24 /* 0xe7d3fbc8 */ (T_MASK ^ 0x182c0437)+#define T25    0x21e1cde6+#define T26 /* 0xc33707d6 */ (T_MASK ^ 0x3cc8f829)+#define T27 /* 0xf4d50d87 */ (T_MASK ^ 0x0b2af278)+#define T28    0x455a14ed+#define T29 /* 0xa9e3e905 */ (T_MASK ^ 0x561c16fa)+#define T30 /* 0xfcefa3f8 */ (T_MASK ^ 0x03105c07)+#define T31    0x676f02d9+#define T32 /* 0x8d2a4c8a */ (T_MASK ^ 0x72d5b375)+#define T33 /* 0xfffa3942 */ (T_MASK ^ 0x0005c6bd)+#define T34 /* 0x8771f681 */ (T_MASK ^ 0x788e097e)+#define T35    0x6d9d6122+#define T36 /* 0xfde5380c */ (T_MASK ^ 0x021ac7f3)+#define T37 /* 0xa4beea44 */ (T_MASK ^ 0x5b4115bb)+#define T38    0x4bdecfa9+#define T39 /* 0xf6bb4b60 */ (T_MASK ^ 0x0944b49f)+#define T40 /* 0xbebfbc70 */ (T_MASK ^ 0x4140438f)+#define T41    0x289b7ec6+#define T42 /* 0xeaa127fa */ (T_MASK ^ 0x155ed805)+#define T43 /* 0xd4ef3085 */ (T_MASK ^ 0x2b10cf7a)+#define T44    0x04881d05+#define T45 /* 0xd9d4d039 */ (T_MASK ^ 0x262b2fc6)+#define T46 /* 0xe6db99e5 */ (T_MASK ^ 0x1924661a)+#define T47    0x1fa27cf8+#define T48 /* 0xc4ac5665 */ (T_MASK ^ 0x3b53a99a)+#define T49 /* 0xf4292244 */ (T_MASK ^ 0x0bd6ddbb)+#define T50    0x432aff97+#define T51 /* 0xab9423a7 */ (T_MASK ^ 0x546bdc58)+#define T52 /* 0xfc93a039 */ (T_MASK ^ 0x036c5fc6)+#define T53    0x655b59c3+#define T54 /* 0x8f0ccc92 */ (T_MASK ^ 0x70f3336d)+#define T55 /* 0xffeff47d */ (T_MASK ^ 0x00100b82)+#define T56 /* 0x85845dd1 */ (T_MASK ^ 0x7a7ba22e)+#define T57    0x6fa87e4f+#define T58 /* 0xfe2ce6e0 */ (T_MASK ^ 0x01d3191f)+#define T59 /* 0xa3014314 */ (T_MASK ^ 0x5cfebceb)+#define T60    0x4e0811a1+#define T61 /* 0xf7537e82 */ (T_MASK ^ 0x08ac817d)+#define T62 /* 0xbd3af235 */ (T_MASK ^ 0x42c50dca)+#define T63    0x2ad7d2bb+#define T64 /* 0xeb86d391 */ (T_MASK ^ 0x14792c6e)++void+md5_data(uint8_t *data,int length, uint8_t digest[16])+{+    md5_state_t state;+    md5_init(&state);+    md5_append(&state,data,length);+    md5_finish(&state,digest);+}++static void+md5_process(md5_state_t *pms, const md5_byte_t *data /*[64]*/)+{+    md5_word_t+	a = pms->abcd[0], b = pms->abcd[1],+	c = pms->abcd[2], d = pms->abcd[3];+    md5_word_t t;+#if BYTE_ORDER == BIG_ENDIAN+    /* Define storage only for big-endian CPUs. */+    md5_word_t X[16];+#else+    /* Define storage for little-endian or both types of CPUs. */+    md5_word_t xbuf[16];+    const md5_word_t *X;+#endif++    {+#if BYTE_ORDER == PDP_ENDIAN+	/*+	 * Determine dynamically whether this is a big-endian or+	 * little-endian machine, since we can use a more efficient+	 * algorithm on the latter.+	 */+	static const int w = 1;++	if (*((const md5_byte_t *)&w)) /* dynamic little-endian */+#endif+#if BYTE_ORDER <= LITTLE_ENDIAN		/* little-endian */+	{+	    /*+	     * On little-endian machines, we can process properly aligned+	     * data without copying it.+	     */+	    if (!((data - (const md5_byte_t *)0) & 3)) {+		/* data are properly aligned */+		X = (const md5_word_t *)data;+	    } else {+		/* not aligned */+		memcpy(xbuf, data, 64);+		X = xbuf;+	    }+	}+#endif+#if BYTE_ORDER == PDP_ENDIAN+	else			/* dynamic big-endian */+#endif+#if BYTE_ORDER == PDP_ENDIAN || BYTE_ORDER == BIG_ENDIAN		/* big-endian */+	{+	    /*+	     * On big-endian machines, we must arrange the bytes in the+	     * right order.+	     */+	    const md5_byte_t *xp = data;+	    int i;++#  if BYTE_ORDER == PDP_ENDIAN+	    X = xbuf;		/* (dynamic only) */+#  else+#    define xbuf X		/* (static only) */+#  endif+	    for (i = 0; i < 16; ++i, xp += 4)+		xbuf[i] = xp[0] + (xp[1] << 8) + (xp[2] << 16) + (xp[3] << 24);+	}+#endif+    }++#define ROTATE_LEFT(x, n) (((x) << (n)) | ((x) >> (32 - (n))))++    /* Round 1. */+    /* Let [abcd k s i] denote the operation+       a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). */+#define F(x, y, z) (((x) & (y)) | (~(x) & (z)))+#define SET(a, b, c, d, k, s, Ti)\+  t = a + F(b,c,d) + X[k] + Ti;\+  a = ROTATE_LEFT(t, s) + b+    /* Do the following 16 operations. */+    SET(a, b, c, d,  0,  7,  T1);+    SET(d, a, b, c,  1, 12,  T2);+    SET(c, d, a, b,  2, 17,  T3);+    SET(b, c, d, a,  3, 22,  T4);+    SET(a, b, c, d,  4,  7,  T5);+    SET(d, a, b, c,  5, 12,  T6);+    SET(c, d, a, b,  6, 17,  T7);+    SET(b, c, d, a,  7, 22,  T8);+    SET(a, b, c, d,  8,  7,  T9);+    SET(d, a, b, c,  9, 12, T10);+    SET(c, d, a, b, 10, 17, T11);+    SET(b, c, d, a, 11, 22, T12);+    SET(a, b, c, d, 12,  7, T13);+    SET(d, a, b, c, 13, 12, T14);+    SET(c, d, a, b, 14, 17, T15);+    SET(b, c, d, a, 15, 22, T16);+#undef SET++     /* Round 2. */+     /* Let [abcd k s i] denote the operation+          a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s). */+#define G(x, y, z) (((x) & (z)) | ((y) & ~(z)))+#define SET(a, b, c, d, k, s, Ti)\+  t = a + G(b,c,d) + X[k] + Ti;\+  a = ROTATE_LEFT(t, s) + b+     /* Do the following 16 operations. */+    SET(a, b, c, d,  1,  5, T17);+    SET(d, a, b, c,  6,  9, T18);+    SET(c, d, a, b, 11, 14, T19);+    SET(b, c, d, a,  0, 20, T20);+    SET(a, b, c, d,  5,  5, T21);+    SET(d, a, b, c, 10,  9, T22);+    SET(c, d, a, b, 15, 14, T23);+    SET(b, c, d, a,  4, 20, T24);+    SET(a, b, c, d,  9,  5, T25);+    SET(d, a, b, c, 14,  9, T26);+    SET(c, d, a, b,  3, 14, T27);+    SET(b, c, d, a,  8, 20, T28);+    SET(a, b, c, d, 13,  5, T29);+    SET(d, a, b, c,  2,  9, T30);+    SET(c, d, a, b,  7, 14, T31);+    SET(b, c, d, a, 12, 20, T32);+#undef SET++     /* Round 3. */+     /* Let [abcd k s t] denote the operation+          a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s). */+#define H(x, y, z) ((x) ^ (y) ^ (z))+#define SET(a, b, c, d, k, s, Ti)\+  t = a + H(b,c,d) + X[k] + Ti;\+  a = ROTATE_LEFT(t, s) + b+     /* Do the following 16 operations. */+    SET(a, b, c, d,  5,  4, T33);+    SET(d, a, b, c,  8, 11, T34);+    SET(c, d, a, b, 11, 16, T35);+    SET(b, c, d, a, 14, 23, T36);+    SET(a, b, c, d,  1,  4, T37);+    SET(d, a, b, c,  4, 11, T38);+    SET(c, d, a, b,  7, 16, T39);+    SET(b, c, d, a, 10, 23, T40);+    SET(a, b, c, d, 13,  4, T41);+    SET(d, a, b, c,  0, 11, T42);+    SET(c, d, a, b,  3, 16, T43);+    SET(b, c, d, a,  6, 23, T44);+    SET(a, b, c, d,  9,  4, T45);+    SET(d, a, b, c, 12, 11, T46);+    SET(c, d, a, b, 15, 16, T47);+    SET(b, c, d, a,  2, 23, T48);+#undef SET++     /* Round 4. */+     /* Let [abcd k s t] denote the operation+          a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s). */+#define I(x, y, z) ((y) ^ ((x) | ~(z)))+#define SET(a, b, c, d, k, s, Ti)\+  t = a + I(b,c,d) + X[k] + Ti;\+  a = ROTATE_LEFT(t, s) + b+     /* Do the following 16 operations. */+    SET(a, b, c, d,  0,  6, T49);+    SET(d, a, b, c,  7, 10, T50);+    SET(c, d, a, b, 14, 15, T51);+    SET(b, c, d, a,  5, 21, T52);+    SET(a, b, c, d, 12,  6, T53);+    SET(d, a, b, c,  3, 10, T54);+    SET(c, d, a, b, 10, 15, T55);+    SET(b, c, d, a,  1, 21, T56);+    SET(a, b, c, d,  8,  6, T57);+    SET(d, a, b, c, 15, 10, T58);+    SET(c, d, a, b,  6, 15, T59);+    SET(b, c, d, a, 13, 21, T60);+    SET(a, b, c, d,  4,  6, T61);+    SET(d, a, b, c, 11, 10, T62);+    SET(c, d, a, b,  2, 15, T63);+    SET(b, c, d, a,  9, 21, T64);+#undef SET++     /* Then perform the following additions. (That is increment each+        of the four registers by the value it had before this block+        was started.) */+    pms->abcd[0] += a;+    pms->abcd[1] += b;+    pms->abcd[2] += c;+    pms->abcd[3] += d;+}++void+md5_init(md5_state_t *pms)+{+    pms->count[0] = pms->count[1] = 0;+    pms->abcd[0] = 0x67452301;+    pms->abcd[1] = /*0xefcdab89*/ T_MASK ^ 0x10325476;+    pms->abcd[2] = /*0x98badcfe*/ T_MASK ^ 0x67452301;+    pms->abcd[3] = 0x10325476;+}++void+md5_append(md5_state_t *pms, const md5_byte_t *data, int nbytes)+{+    const md5_byte_t *p = data;+    int left = nbytes;+    int offset = (pms->count[0] >> 3) & 63;+    md5_word_t nbits = (md5_word_t)(nbytes << 3);++    if (nbytes <= 0)+	return;++    /* Update the message length. */+    pms->count[1] += nbytes >> 29;+    pms->count[0] += nbits;+    if (pms->count[0] < nbits)+	pms->count[1]++;++    /* Process an initial partial block. */+    if (offset) {+	int copy = (offset + nbytes > 64 ? 64 - offset : nbytes);++	memcpy(pms->buf + offset, p, copy);+	if (offset + copy < 64)+	    return;+	p += copy;+	left -= copy;+	md5_process(pms, pms->buf);+    }++    /* Process full blocks. */+    for (; left >= 64; p += 64, left -= 64)+	md5_process(pms, p);++    /* Process a final partial block. */+    if (left)+	memcpy(pms->buf, p, left);+}++void+md5_finish(md5_state_t *pms, md5_byte_t digest[16])+{+    static const md5_byte_t pad[64] = {+	0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,+	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,+	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,+	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0+    };+    md5_byte_t data[8];+    int i;++    /* Save the length before padding. */+    for (i = 0; i < 8; ++i)+	data[i] = (md5_byte_t)(pms->count[i >> 2] >> ((i & 3) << 3));+    /* Pad to 56 bytes mod 64. */+    md5_append(pms, pad, ((55 - (pms->count[0] >> 3)) & 63) + 1);+    /* Append the length. */+    md5_append(pms, data, 8);+    for (i = 0; i < 16; ++i)+	digest[i] = (md5_byte_t)(pms->abcd[i >> 2] >> ((i & 3) << 3));+}
+ src/data/targets.ini view
@@ -0,0 +1,90 @@+;+; configuration file for architectures and compiler options.+;+; the final value set is the one used.+;+; all '-m' parameters on the command line are parsed and processed in order.+;+; there is an implicit -mdefault processed first+; entries in the user config file are appended to this one.+;+; the cross compilation entries in this file should be treated as examples.+; although they work out of the box for many systems, cross compilation+; environments differ, so you may need to override them for your+; specific setup.++[default]+cc=gcc+gc=jgc+cflags=-std=gnu99 -D_GNU_SOURCE -falign-functions=4 -ffast-math -Wextra -Wall -Wno-unused-parameter -fno-strict-aliasing+cflags_debug=-g+cflags_nodebug=-DNDEBUG -O3+profile=false+autoload=haskell2010,haskell-extras,haskell98+++; cross compilation entries++[win32]+cc=i386-mingw32-gcc+executable_extension=.exe+merge=i686++[wii]+cc=powerpc-eabi-gcc+byteorder=be+cflags+=-g -DGEKKO -D__WORDSIZE=32 -mrvl -mcpu=750 -meabi -mhard-float+executable_extension=.elf+bits=32+bits_max=64+merge=be32++; macintosh, this is for cross compiling, not for native compilation on osx+[osx]++[osx-intel]+cc=i686-apple-darwin9-gcc+merge=i686+merge=osx++[osx-powerpc]+cc=powerpc-apple-darwin9-gcc+merge=be32+merge=osx++; a couple specific cpus+[i686]+merge=le32+arch=i686+bits_max=64+cflags_nodebug+=-fomit-frame-pointer++[x86_64]+bits_max=64+merge=le64++[le32]++byteorder=le+merge=32++[be32]+byteorder=be+merge=32++[le64]+byteorder=le+merge=64++[be64]+byteorder=be+merge=64++[32]+cflags+=-m32+bits=32++[64]+cflags+=-m64+bits=64+
+ src/hs_src_config.h view
@@ -0,0 +1,6 @@+#ifndef HS_SRC_CONFIG+#define HS_SRC_CONFIG++#define HAS_MONOID_DOC 1++#endif
+ utils/build_extlibs.prl view
@@ -0,0 +1,67 @@+#!/usr/bin/perl++use strict;+use warnings;++# xxx LWP getstore may return 500 error on Windows+msys+virtualbox.+# xxx I can't understand the below MAGIC...+# xxx http://lwp.interglacial.com/ch02_03.htm+use LWP::Simple qw(!head);+use Cwd;+use Getopt::Std;++our ($opt_l,$opt_d,$opt_c);+getopts('ldc:') or die "unknown opt";+$opt_c = "./ajhc" unless $opt_c;++# clean out environment+delete $ENV{AJHC_PATH};+delete $ENV{AJHC_OPTS};+delete $ENV{AJHC_CACHE};+delete $ENV{AJHC_LIBRARY_PATH};++my $tmpdir = "tmp/build";++mkdir "tmp";+mkdir "tmp/build";++sub mysystem {+    print( (join " ", @_), "\n");+    system @_ and die "Running Command Failed!";+}++foreach my $fn (@ARGV) {+    next unless $fn =~ /\.(cabal|yaml)$/;+    my $patch = $fn;+    $patch =~ s/\.(cabal|yaml)$/.patch/;+    print "Processing $fn\n" unless $opt_l;+    open my $fh, "<", $fn or die "$!: $fn";+    my ($name,$version,$options);+    $options = "";+    while(<$fh>) {+        $name = $1 if /^name:\s*(.*?)\s*$/i;+        $version = $1 if /^version:\s*(.*?)\s*$/i;+        $options = $1 if /^options:\s*(.*?)\s*$/i;+    }+    next unless $name;+    next unless $version;++    $options = "$options --stop deps --deps tmp/$name-deps.yaml" if $opt_d;++    print("$name-$version.hl\n"),next if $opt_l;++    print "Processing $fn, found $name-$version\n";+    my $url = "http://hackage.haskell.org/packages/archive/$name/$version/$name-$version.tar.gz";+    print "Fetching $url\n";+    unless(-e "$tmpdir/$name-$version.tar.gz") {+        my $rc = getstore($url, "$tmpdir/$name-$version.tar.gz");+        if (is_error $rc) { die "$url: $rc" } ;+    }+    mysystem "tar -zxv --directory $tmpdir -f $tmpdir/$name-$version.tar.gz" and die "$!: tar";+    my $src = -d "$tmpdir/$name-$version/src" ? "/src" : "";+    mysystem "patch -d $tmpdir/$name-$version -p1 < $patch" if -e $patch;+    mysystem("cp '$fn' '$tmpdir/$name-$version'");+    $fn =~ s/.*\///;+    mysystem("$opt_c $options " . ($ENV{AJHC_TEST} || "") .+        " --build-hl '$tmpdir/$name-$version/$fn' -L- -L. -i- '-i$tmpdir/$name-$version$src'") and die "$!: ajhc";+}