packages feed

lhc 0.6.20090126 → 0.8

raw patch · 384 files changed

+34938/−57306 lines, 384 filesdep +Cabaldep +bytestring-triedep +coredep −ansi-terminaldep −arraydep −fgldep ~ansi-wl-pprintdep ~basedep ~binarysetup-changednew-component:exe:lhc-pkg

Dependencies added: Cabal, bytestring-trie, core, digest, extensible-exceptions, ghc, libffi, xhtml

Dependencies removed: ansi-terminal, array, fgl, graphviz, old-time, pureMD5, random, regex-compat, stringtable-atom, syb, utf8-string, zlib

Dependency ranges changed: ansi-wl-pprint, base, binary, derive

Files

− COPYING 
@@ -1,350 +0,0 @@-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.
Setup.hs view
@@ -1,17 +1,25 @@ import System.Cmd (system)-import System.FilePath ((</>))-import Control.Monad (when, unless)+import System.Process (readProcess)+import System.FilePath+import Control.Monad (when, unless, liftM)+import System.Directory+import System.Info as SysVer+import Data.Version import Distribution.Simple import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription import Distribution.Simple.InstallDirs (CopyDest(..)) import Distribution.Simple.LocalBuildInfo (absoluteInstallDirs, InstallDirs(..)) +lhclibdir = "lib"+libsToBuild = map (lhclibdir </>) [ "ghc-prim", "integer-native", "base" ]+ main = defaultMainWithHooks simpleUserHooks { postInst = myPostInst }-  where myPostInst _ _ pkgdesc buildinfo = do -          let dirs  = absoluteInstallDirs pkgdesc buildinfo NoCopyDest-              lhc   = bindir dirs </> "lhc"-              confargs = unwords ["--lhc", "--with-lhc="++lhc, "--prefix="++show (prefix (installDirTemplates buildinfo))]+  where myPostInst _ _ pkgdesc buildinfo = do+          let dirs   = absoluteInstallDirs pkgdesc buildinfo NoCopyDest+              pkgVer = pkgVersion (package pkgdesc)+              lhc    = bindir dirs </> "lhc"+              lhcpkg = bindir dirs </> "lhc-pkg"               lpkgdesc = localPkgDescr buildinfo               exes     = executables lpkgdesc               sanity   = any (\(Executable s _ _) -> s == "lhc") exes@@ -19,15 +27,49 @@           let lhcexe   = head $ filter (\(Executable s _ _) -> s == "lhc") exes               binfo    = buildInfo lhcexe               customF  = customFieldsBI binfo-          when (withBase customF) $ installLhcPkg confargs "base"-        withBase = any $ \(x,y) -> x == "x-build-base" && y == "True"+          -- initial setup+          udir' <- getAppUserDataDirectory "lhc"+          -- NOTE - THIS MUST BE KEPT IN SYNC WITH+          -- lhc-pkg in lhc-pkg/Main.hs!!!+          let udir =  udir' </> (SysVer.arch ++ "-" ++ SysVer.os ++  "-" ++ (showVersion pkgVer))+              pkgconf = udir </> "package" <.> "conf"+          b <- doesFileExist pkgconf+          unless b $ do+            putStr "Creating initial package.conf file..."+            createDirectoryIfMissing True udir+            writeFile (udir </> "package.conf") "[]\n"+            putStrLn "Done"++          -- copy over extra-gcc-opts and unlit from+          -- ghc's libdir+          -- NOTE FIXME: this assumes that the 'ghc' executable+          -- points to the same one you compiled LHC against; although,+          -- the compile options would probably roughly stay the same anyway+          ghcLibdir <- liftM (unwords . words) $ readProcess "ghc" ["--print-libdir"] []+          let unlit          = ghcLibdir </> "unlit"+              extragccopts = ghcLibdir </> "extra-gcc-opts"+          putStr "Copying unlit and extra-gcc-opts..."+          system $ "cp "++unlit++" "++(udir </> "unlit")+          system $ "cp "++extragccopts++" "++(udir </> "extra-gcc-opts")+          putStrLn "Done"+          -- build libraries if -fwith-libs is passed+          when (withLibs customF) $ do+            let confargs = unwords [ "--lhc", "--with-lhc="++lhc, "--with-lhc-pkg="++lhcpkg+                                   , "--prefix="++show (prefix (installDirTemplates buildinfo))+                                   , "--extra-include-dirs="++(ghcLibdir</>"include") ]+            putStrLn "building libraries..."+            installLhcPkgs confargs libsToBuild++        withLibs = any $ \(x,y) -> x == "x-build-libs" && y == "True"         installLhcPkgs cf  = mapM_ (installLhcPkg cf)-        installLhcPkg cf n = do +        installLhcPkg cf n = do             putStrLn $ "\n[installing "++n++" package for lhc]\n"-            let x = unwords ["cd","lib" </> n+            let x = unwords ["cd",n                             ,"&&","runghc Setup configure",cf                             ,"&&","runghc Setup build"-                            ,"&&","runghc Setup install"]+                            ,"&&","runghc Setup copy"+                            ,"&&","runghc Setup register"]             putStrLn $ x             system x+            putStrLn "\nDone"             return ()
− data/HsFFI.h 
@@ -1,41 +0,0 @@-/* HsFFI.h for lhc */--#ifndef _LHC_HSFFI_H-#define _LHC_HSFFI_H--#include <inttypes.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 uint32_t HsChar;-typedef int 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
− data/names.txt 
@@ -1,131 +0,0 @@--TypeConstructor:tc:--JumpPoint Lhc.JumpPoint.JumpPoint-Char      Lhc.Prim.Char-IO        Lhc.Prim.IO-World__   Lhc.Prim.World__-Bool      Lhc.Order.Bool-Target    Lhc.Options.Target-Ptr       Lhc.Addr.Ptr-Addr      Lhc.Addr.Addr-FunAddr   Lhc.Addr.FunAddr-Ratio     Lhc.Num.Ratio-Unit      Lhc.Basics.()-Float     Lhc.Float.Float-Double    Lhc.Float.Double-CLong     Foreign.C.Types.CLong-CSChar    Foreign.C.Types.CSChar-CUChar    Foreign.C.Types.CUChar-CUShort   Foreign.C.Types.CUShort-CULong    Foreign.C.Types.CULong--Bits1      Lhc.Types.Bits1_-Bits8      Lhc.Types.Bits8_-Bits16     Lhc.Types.Bits16_-Bits32     Lhc.Types.Bits32_-Bits64     Lhc.Types.Bits64_-Bits128    Lhc.Types.Bits128_-BitsPtr    Lhc.Types.BitsPtr_-BitsMax    Lhc.Types.BitsMax_-BitsSize   Lhc.Types.BitsSize_t_-BitsShort  Lhc.Types.BitsShort_-BitsInt    Lhc.Types.BitsInt_--Float32    Lhc.Types.Float32_-Float64    Lhc.Types.Float64_-Float80    Lhc.Types.Float80_-Float128   Lhc.Types.Float128_--DataConstructor:dc:--Rational   Lhc.Num.:%-Cons       Lhc.Prim.:-EmptyList  Lhc.Prim.[]-Unit       Lhc.Basics.()-Boolzh     Lhc.Order.Bool#-Target     Lhc.Options.Target#-Char       Lhc.Prim.Char-Addr       Lhc.Addr.Addr--ClassName:class:-Eq              Lhc.Order.Eq-Ord             Lhc.Order.Ord-Enum            Lhc.Enum.Enum-Bounded         Lhc.Enum.Bounded-Show            Lhc.Show.Show-Read            Lhc.Text.Read-Ix              Data.Ix.Ix-Functor         Lhc.Monad.Functor-Monad           Lhc.Monad.Monad-Num             Lhc.Num.Num-Real            Lhc.Num.Real-Integral	Lhc.Num.Integral-Fractional	Lhc.Num.Fractional-Floating	Lhc.Float.Floating-RealFrac	Lhc.Float.RealFrac-RealFloat	Lhc.Float.RealFloat--RawType:rt:--bits128         bits128-bool            bool-float32         fbits32-float64         fbits64-float80         fbits80-float128        fbits128--Val:v:-eqString         Lhc.String.eqString-eqUnpackedString Lhc.String.eqUnpackedString-unpackString     Lhc.String.unpackString-target           Lhc.Options.target-error            Lhc.IO.error-minBound         Lhc.Enum.minBound-maxBound         Lhc.Enum.maxBound-fail             Lhc.Monad.fail-map              Lhc.Basics.map-and              Lhc.Order.&&-filter           Lhc.List.filter-foldr            Lhc.Basics.foldr-undefined        Lhc.Basics.undefined---bind                 Lhc.Monad.>>=-bind_                Lhc.Monad.>>-return               Lhc.Monad.return-concatMap            Lhc.Basics.concatMap-fromInteger          Lhc.Num.fromInteger-fromInt              Lhc.Num.fromInt-fromRational         Lhc.Num.fromRational-negate               Lhc.Num.negate-leq                  Lhc.Order.<=-geq                  Lhc.Order.>=-lt                   Lhc.Order.<-gt                   Lhc.Order.>-compare              Lhc.Order.compare-equals               Lhc.Order.==-neq                  Lhc.Order./=-fromEnum             Lhc.Enum.fromEnum-toEnum               Lhc.Enum.toEnum-enumFrom             Lhc.Enum.enumFrom-enumFromTo           Lhc.Enum.enumFromTo-enumFromThenTo       Lhc.Enum.enumFromThenTo-enumFromThen         Lhc.Enum.enumFromThen-succ                 Lhc.Enum.succ-pred                 Lhc.Enum.pred-range                Data.Ix.range-index                Data.Ix.index-inRange              Data.Ix.inRange-runExpr              Prelude.IO.runExpr-runRaw               Lhc.Prim.runRaw-runMain              Lhc.IO.runMain-runNoWrapper         Lhc.Prim.runNoWrapper--enum_succ            Lhc.Inst.PrimEnum.enum_succ-enum_pred            Lhc.Inst.PrimEnum.enum_pred-enum_from            Lhc.Inst.PrimEnum.enum_from-enum_fromTo          Lhc.Inst.PrimEnum.enum_fromTo-enum_fromThen        Lhc.Inst.PrimEnum.enum_fromThen-enum_fromThenTo      Lhc.Inst.PrimEnum.enum_fromThenTo-enum_toEnum          Lhc.Inst.PrimEnum.enum_toEnum
− data/operators.txt 
@@ -1,36 +0,0 @@----[int,float,char,ptr]-aaB, ==, Lhc.Order.Eq, ==-# aaB, /=, Lhc.Order.Eq, !=-aaB, >=, Lhc.Order.Ord, >=-aaB, <=, Lhc.Order.Ord, <=-aaB, >, Lhc.Order.Ord, >-aaB, <, Lhc.Order.Ord, <---[int,float]-aaa, +, Lhc.Num.Num, +-aaa, -, Lhc.Num.Num, --aaa, *, Lhc.Num.Num, *-aa, negate, Lhc.Num.Num, --# 1, abs, Lhc.Num.Num, abs-# 1, signum, Lhc.Num.Num, abs--[int]-aaa, .&., Data.Bits.Bits, &-aaa, .|., Data.Bits.Bits, |-aaa, xor, Data.Bits.Bits, ^-aa, complement, Data.Bits.Bits, ~-aaa, quot, Lhc.Num.Integral, /-aaa, rem, Lhc.Num.Integral, %-aaa, div, Lhc.Num.Integral, /-aaa, mod, Lhc.Num.Integral, %-aIa, shiftL, Data.Bits.Bits, <<-aIa, shiftR, Data.Bits.Bits, >>---# [float]-# aaa, /, Lhc.Num.Fractional, /-
− data/prelude.m4 
@@ -1,4 +0,0 @@-m4_changequote({{,}})-m4_changecom({-,-})--m4_define(ONCE,{{m4_ifdef(done-$1,{{m4_dnl}},{{m4_define(done-$1,1)$1}})}})
− data/primitives.txt 
@@ -1,40 +0,0 @@-# Ideally, people should be able to declare these in the program.--# limits.h, float.h, inttypes.h--# Lhc.Prim.Char, ubits32, char, UINT32_MAX, 0-Lhc.Prim.Int, sbits32, int, INT_MAX, INT_MIN-Lhc.Basics.Integer, sbits<max>, int, INTMAX_MAX, INTMAX_MIN--Data.Int.Int8, sbits8, int, INT8_MAX, INT8_MIN-Data.Int.Int16, sbits16, int, INT16_MAX, INT16_MIN-Data.Int.Int32, sbits32, int, INT32_MAX, INT32_MIN-Data.Int.Int64, sbits64, int, INT64_MAX, INT64_MIN-Data.Int.IntMax, sbits<max>, int, INTMAX_MAX, INTMAX_MIN-Data.Int.IntPtr, sbits<ptr>, int, INTPTR_MAX, INTPTR_MIN--Data.Word.Word, ubits32, int, UINT_MAX, 0-Data.Word.Word8, ubits8, int, UINT8_MAX, 0-Data.Word.Word16, ubits16, int, UINT16_MAX, 0-Data.Word.Word32, ubits32, int, UINT32_MAX, 0-Data.Word.Word64, ubits64, int, UINT64_MAX, 0-Data.Word.WordMax, ubits<max>, int, UINTMAX_MAX, 0-Data.Word.WordPtr, ubits<ptr>, int, UINTPTR_MAX, 0--#Lhc.Float.Float, fbits<float>, float, FLT_MAX, FLT_MIN-#Lhc.Float.Double, fbits<double>, float, DBL_MAX, DBL_MIN--#Lhc.Addr.Addr, ubits<ptr>, ptr,UINTPTR_MAX, 0-#Lhc.Addr.FunAddr, ubits<ptr>, ptr,UINTPTR_MAX,0--Foreign.C.Types.CChar, sbits8, int, CHAR_MAX, CHAR_MIN-Foreign.C.Types.CShort, sbits<short>, int, SHORT_MAX, SHORT_MIN-Foreign.C.Types.CInt, sbits<int>, int, INT_MAX, INT_MIN-Foreign.C.Types.CUInt, ubits<int>, int, UINT_MAX, 0-Foreign.C.Types.CSize, ubits<size_t>, int, UINTPTR_MAX, 0-Foreign.C.Types.CWchar, ubits32, int, 0x10FFFF, 0-Foreign.C.Types.CWint, sbits32, int, 0x10FFFF, 0-# not really right, need to find out actual minimum/maximum somehow-Foreign.C.Types.CTime, ubits<time_t>, float, 0xffffffffff, 0--
− data/props.txt 
@@ -1,26 +0,0 @@-# These are set by user pragmas-INLINE-MULTISPECIALIZE-NOINLINE-SRCLOC_ANNOTATE-SUPERINLINE-NOETA--# these are used internaly by the compiler-_CYCLIC-_EXPORTED-_INSTANCE-_JOINPOINT-_METHOD-_ONESHOT-_PLACEHOLDER-_RULEBINDER-_SCRUTINIZED-_SPECIALIZATION-_SRCLOC_ANNOTATE_FUN-_SUPERSPECIALIZE-_UNSHARED-_WHNF-_WORKER-_WRAPPER-_HASRULE
− data/rts/lhc_rts.c 
@@ -1,143 +0,0 @@--static void _amain(void);-static void lhc_arch_assert(void);-static int lhc_argc;-static char **lhc_argv;-static char *lhc_progname;-static jmp_buf lhc_uncaught;--static HsInt lhc_stdrnd[2] A_UNUSED = { 1 , 1 };--#if _LHC_PROFILE--static uintmax_t lhc_prof_function_calls;-static uintmax_t lhc_prof_case_statements;-static uintmax_t lhc_prof_updates;--#define lhc_update_inc()   lhc_prof_updates++-#define lhc_function_inc() lhc_prof_function_calls++-#define lhc_case_inc()     lhc_prof_case_statements++--#else--#define lhc_update_inc()    do { } while(0)-#define lhc_function_inc()  do { } while(0)-#define lhc_case_inc()      do { } while(0)--#endif--static void A_COLD-lhc_print_profile(void) {-        struct tms tm;-        times(&tm);-        if(!(_LHC_PROFILE || getenv("LHC_RTS_PROFILE"))) return;--        fprintf(stderr, "\n-----------------\n");-        fprintf(stderr, "Profiling: %s\n", lhc_progname);-        fprintf(stderr, "Command: %s\n", lhc_command);-        fprintf(stderr, "Complie: %s\n", lhc_c_compile);-        fprintf(stderr, "Version: %s\n\n", lhc_version);-        lhc_alloc_print_stats();-        float cpt = (float)sysconf(_SC_CLK_TCK);-        fprintf(stderr, "User Time:   %.2fs\n", (float)tm.tms_utime/cpt);-        fprintf(stderr, "System Time: %.2fs\n", (float)tm.tms_stime/cpt);-        fprintf(stderr, "Total Time:  %.2fs\n", (float)(tm.tms_stime + tm.tms_utime)/cpt);--#if _LHC_PROFILE-        fprintf(stderr, "\nFunction Calls:   %llu\n", (unsigned long long)lhc_prof_function_calls);-        fprintf(stderr, "Case Statements:  %llu\n", (unsigned long long)lhc_prof_case_statements);-        fprintf(stderr, "Updates:          %llu\n", (unsigned long long)lhc_prof_updates);-#endif-        fprintf(stderr, "-----------------\n");-}---static void A_NORETURN A_UNUSED A_COLD-lhc_exit(int n) {-        lhc_print_profile();-        exit(n);-}--static void  A_NORETURN A_UNUSED  A_COLD-lhc_error(char *s) {-        fputs(s,stderr);-        fputs("\n",stderr);-        lhc_print_profile();-        exit(255);-}--static void  A_NORETURN A_UNUSED  A_COLD-lhc_case_fell_off(int n) {-        fflush(stdout);-        fprintf(stderr, "\n%s:%i: case fell off\n", __FILE__, n);-        abort();-}--#define lhc_setjmp(jb) sigsetjmp(*(jmp_buf *)jb,0)-#define lhc_longjmp(jb) siglongjmp(*(jmp_buf *)jb,1)--struct lhc_continuation {-    void *argument;-    jmp_buf jump_buf;-};--#define prim_umaxbound(t) ((t)~((t)0))-#define prim_maxbound(t) ((t)(~((t)1 << (sizeof(t)*8 - 1))))-#define prim_minbound(t) ((t)(((t)1 << (sizeof(t)*8 - 1))))---inline static int A_UNUSED-lhc_utf8_getchar(void)-{-    return getchar_unlocked();-}--inline static int A_UNUSED-lhc_utf8_getc(FILE *f)-{-    return getc_unlocked(f);-}--inline static int A_UNUSED-lhc_utf8_putchar(int ch)-{-    return putchar_unlocked(ch);-}--inline static int A_UNUSED-lhc_utf8_putc(int ch, FILE *f)-{-    return putc_unlocked(ch,f);-}---int  A_COLD-main(int argc, char *argv[])-{-        /* A few random assertions about the architecture that the compiler-         * assumes. should be true of any but the oddest of beasts.-         */--        assert(sizeof(HsPtr) == sizeof(HsFunPtr));-        assert(sizeof(HsPtr) == sizeof(intptr_t));-        assert(sizeof(HsPtr) == sizeof(uintptr_t));-        assert(CHAR_BIT == 8);-        assert(EOF == -1);--        lhc_arch_assert();-        lhc_malloc_init();-        lhc_argc = argc - 1;-        lhc_argv = argv + 1;-        lhc_progname = argv[0];-        setlocale(LC_ALL,"");-        if (sigsetjmp(lhc_uncaught,0))-                lhc_error("Uncaught Exception");-        else-                _amain();-        lhc_print_profile();-        return 0;-}----
− data/rts/lhc_rts2.c 
@@ -1,251 +0,0 @@--#define ISLAZY(x)    (((uintptr_t)(x)) & 0x1)-#define DETAG(x)     ((uintptr_t)(x) & ~0x3)-#define GETTAG(x)    ((uintptr_t)(x) & 0x3)--#define GETHEAD(x)   (NODEP(x)->head)-#define NODEP(x)     ((node_t *)(x))-#define DNODEP(x)    ((dnode_t *)(x))-#define EVALTAG(fn)  (assert(((uintptr_t)(fn) & 0x3) == 0),(sptr_t)((uintptr_t)(fn) | P_LAZY))-#define EVALTAGC(fn) ((sptr_t)((void *)(fn) + P_LAZY))-#define EVALFUNC(fn) ((fptr_t)((uintptr_t)(fn) | P_FUNC))-#define VALUE(n)     ((wptr_t)(((intptr_t)(n) << 2) | P_VALUE))-#define GETVALUE(n)  ((intptr_t)(n) >> 2)-#define ISVALUE(n)   (assert(!ISLAZY(n)), ((uintptr_t)(n) & 0x2))-#define PROMOTE(n)   ((wptr_t)(n))-#define DEMOTE(n)    ((sptr_t)(n))-#define GETWHAT(x)   (GETTAG(x) == P_VALUE ? ((uintptr_t)(x) >> 16) : DNODEP(x)->what)--#define SETWHAT(x,v)   (DNODEP(x)->what = (v))-#define RAWWHAT(w)     (wptr_t)(((uintptr_t)w << 16) | P_VALUE)---#define P_WHNF  0x0-#define P_LAZY  0x1-#define P_VALUE 0x2-#define P_FUNC  0x3--#define BLACK_HOLE ((fptr_t)0xDEADBEEF)---/*@Internals--# The Run Time System--Lhc 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, we call whatever conventions and binary layouts used in the generated-executable the run time system. Since lhc generates the code anew each time, it-can build a different 'run time' based on compiler options, trading things like-the garbage collector as needed or changing the closure layout when we know we-have done full program optimization. This describes the 'native' layout upon-which other conventions are layered.--A basic value in lhc is represented by a 'smart pointer' of c type sptr_t. a-smart pointer is the size of a native pointer, but can take on different roles-depending on a pair of tag bits.--smart pointers take on a general form as follows:--    --------------------------    |    payload        | GL|-    ---------------------------      G - if set, then the garbage collector should not treat value as a pointer to be followed-      L - lazy, this bit being set means the value is not in WHNF--A raw sptr_t on its own in the wild can only take on one of the following values:--    --------------------------    |    raw value      | 10|-    ---------------------------    --------------------------    |    whnf location  | 00|-    ---------------------------    --------------------------    |   lazy location   | 01|-    ---------------------------A raw value can be anything and not necessarily a pointer in general, a WHNF-location is a pointer to some value in WHNF. The system places no restrictions-on what is actually pointed to by a WHNF pointer, however the garbage collector-in use may. In general, the back end is free to choose what to place in the raw-value field or in what a WHNF points to with complete freedom. If an-implementation sees the L bit is clear, it can pass on the smart pointer-without examining it knowing the value is in WHNF.--A lazy location points to a potential closure or an indirection to a WHNF-value. The lazy location is an allocated chunk of memory that is at least-one pointer long. the very first location in a closure must be one of the-following.--    --------------------------    | raw value or whnf  |X0|-    ---------------------------An evaluated value, interpreted exactly as above. one can always replace any occurance of a-lazy location with an evaluated indirecton.--    --------------------------    |    code pointer   | 11|-    --------------------------    |     data ...          |--This is something to evaluate, code pointer is a pointer to a function that takes-the memory location as its only argument, the called function is in charge-of updating the location if needed.--note that it is invalid to have a lazy location point to another lazy-location. there is only ever one level of indirection allowed, and only from-lazy locations--note that a partial application is just like any other value in WHNF as far-as the above is concered. It happens to possibly contain a code pointer.--*/---/*- * type names- *- * sptr_t - a tagged smart pointer, may be a value, may be a pointer to a whnf or lazy location- * wptr_t - a value guarenteed to be in whnf- * fptr_t - a pointer to a whnf or a function pointer to something to evaluate, first value in a lazy location.- * what_t  - the discriminator of a discriminated union- *- */--typedef struct node *  sptr_t;-typedef struct dnode * wptr_t;-typedef void *         fptr_t;-typedef uintptr_t      what_t;---typedef struct node {-        fptr_t head;-        sptr_t rest[];-} A_MAYALIAS node_t;--typedef struct dnode {-        what_t what;-        sptr_t rest[];-} A_MAYALIAS dnode_t;--#if _LHC_DEBUG--// these ensure the type synonyms are available to the debugger-uintptr_t _dummy1;-node_t *_dummy2;-dnode_t *_dummy3;-sptr_t *_dummy4;-fptr_t *_dummy5;-wptr_t *_dummy6;---static int A_UNUSED-lhc_valid_whnf(wptr_t s)-{-        return ((GETTAG(s) == P_VALUE) || ((GETTAG(s) == P_WHNF) && lhc_malloc_sanity(s,P_WHNF)));-}--static int A_UNUSED-lhc_valid_lazy(sptr_t s)-{-        if(lhc_valid_whnf((wptr_t)s))-                return 1;-        assert(GETTAG(s) == P_LAZY);-        node_t *ds = (sptr_t)DETAG(s);-        assert(lhc_malloc_sanity(ds,P_LAZY));-        if(ISLAZY(ds->head)) {-                if(ds->head == BLACK_HOLE) return 1;-                assert(GETTAG(ds->head) == P_FUNC);-                fptr_t dhead = (fptr_t)DETAG(ds->head);-                return 1;-        } else-                return lhc_valid_whnf((wptr_t)ds->head);-}---#else--#define lhc_valid_whnf(x) 1-#define lhc_valid_lazy(x) 1--#endif---typedef wptr_t (*eval_fn)(node_t *node) A_STD;--// both promote and demote evaluate to nothing when debugging is not enabled-// otherwise, they check that their arguments are in the correct form.--static inline wptr_t A_STD A_UNUSED  A_HOT-promote(sptr_t s)-{-        assert(!ISLAZY(s));-        assert(lhc_valid_whnf((wptr_t)s));-        return (wptr_t)s;-}--static inline sptr_t A_STD A_UNUSED A_HOT-demote(wptr_t s)-{-        assert(!ISLAZY(s));-        assert(lhc_valid_whnf(s));-        return (sptr_t)s;-}--// like eval but you know the target is in WHNF or is a already evaluated indirection-static inline wptr_t A_STD A_UNUSED  A_HOT-follow(sptr_t s)-{-        assert(lhc_valid_lazy(s));-        if(ISLAZY(s)) {-                sptr_t h = (sptr_t)(GETHEAD(DETAG(s)));-                assert(!ISLAZY(h));-                return (wptr_t)h;-        }-        return (wptr_t)s;-}--static inline wptr_t A_STD A_UNUSED  A_HOT-eval(sptr_t s)-{-        assert(lhc_valid_lazy(s));-        if(ISLAZY(s)) {-                assert(GETTAG(s) == P_LAZY);-                void *ds = (void *)DETAG(s);-                sptr_t h = (sptr_t)(GETHEAD(ds));-                assert(h != BLACK_HOLE);-                if(ISLAZY(h)) {-                        eval_fn fn = (eval_fn)DETAG(h);-#if _LHC_DEBUG-                        GETHEAD(ds) = BLACK_HOLE;-#endif-                        wptr_t r = (*fn)(NODEP(ds));-#if _LHC_DEBUG-                        assert(GETHEAD(ds) != BLACK_HOLE);-#endif-                        return r;-                }-                return (wptr_t)h;-        }-        assert(lhc_valid_whnf((wptr_t)s));-        return (wptr_t)s;-}---static inline void A_STD A_UNUSED A_HOT-update(sptr_t thunk, wptr_t new)-{-        lhc_update_inc();-        assert(GETHEAD(thunk) == BLACK_HOLE);-        assert(!ISLAZY(new));-        GETHEAD(thunk) = (fptr_t)new;-}----
− data/rts/lhc_rts_alloc.c 
@@ -1,138 +0,0 @@--// some default definitions--#define lhc_malloc_whnf lhc_malloc-#define lhc_malloc_suspension lhc_malloc-#define lhc_malloc_atomic lhc_malloc-#define lhc_malloc_atomic_whnf lhc_malloc_atomic-#define lhc_malloc_sanity(p,t) (1)--#if _LHC_PROFILE--#define BUCKETS 7--static unsigned alloced[BUCKETS];-static unsigned alloced_atomic[BUCKETS];--static void-alloc_count(int n,int atomic)-{-        n = n ? ((n - 1)/sizeof(void *)) + 1 : 0;-        n = n > BUCKETS - 1 ? BUCKETS - 1 : n;-        (atomic ? alloced_atomic : alloced)[n]++;-}---static void-print_alloc_size_stats(void) {-        char fmt[] = "%10s %10s %10s %10s %10s\n";-        char fmt2[] = "%10u %10u %10u %10u %10u\n";-        fprintf(stderr,fmt,"Size","Normal","Atomic","Total","Accum");-        fprintf(stderr,fmt,"----","------","------","-----","-----");-        unsigned accum = 0;-        for(int i = 0; i < BUCKETS; i++) {-                accum += alloced[i] + alloced_atomic[i];-                fprintf(stderr,fmt2,i,alloced[i],alloced_atomic[i],alloced_atomic[i] + alloced[i], accum);-        }-}---#else--#define alloc_count(x,y)-#define print_alloc_size_stats()--#endif /* _LHC_PROFILE */--#if _LHC_GC == _LHC_GC_BOEHM--#include <gc/gc.h>--#define lhc_malloc GC_malloc-#undef  lhc_malloc_atomic-#define lhc_malloc_atomic GC_malloc_atomic-#define lhc_free GC_free--static inline void lhc_malloc_init(void) { GC_INIT(); }-static inline void lhc_alloc_print_stats(void) { GC_dump(); }--#elif _LHC_GC == _LHC_GC_NONE--// memory allocated in 1MB chunks.-#define LHC_MEM_CHUNK_SIZE (1 << 20)--static char initial_chunk[LHC_MEM_CHUNK_SIZE];--static void *lhc_current_chunk = initial_chunk;-static unsigned mem_chunks,mem_offset;---static inline void-lhc_malloc_init(void) { return; }--static void-lhc_alloc_print_stats(void) {-        fprintf(stderr, "Memory Allocated: %u bytes\n", (LHC_MEM_CHUNK_SIZE*(mem_chunks)) + mem_offset);-        print_alloc_size_stats();-}--static void-lhc_malloc_grow(void) {-        void *c = malloc(LHC_MEM_CHUNK_SIZE);-        if(!c) {-                fputs("Out of memory!\n",stderr);-                abort();-        }-        mem_chunks++;-        lhc_current_chunk = c;-        mem_offset = 0;-}--static inline void * A_MALLOC-lhc_malloc_basic(size_t n) {-        n = ALIGN(sizeof(void *),n);-        if (n > (LHC_MEM_CHUNK_SIZE - mem_offset))-                lhc_malloc_grow();-        void *ret = lhc_current_chunk + mem_offset;-        mem_offset += n;-        return ret;-}---#if _LHC_DEBUG--#define lhc_malloc(n) lhc_malloc_debug(n,__LINE__,0)-#undef lhc_malloc_atomic-#define lhc_malloc_atomic(n) lhc_malloc_debug(n,__LINE__,1)--static void * A_MALLOC-lhc_malloc_debug(size_t n,int line,int atomic) {-        alloc_count(n,atomic);-        void *ret = lhc_malloc_basic(n + sizeof(uintptr_t));-        *((uintptr_t *)ret) = line;-        return ret + sizeof(uintptr_t);-}--#else--static inline void * A_MALLOC-lhc_malloc(size_t n) {-        alloc_count(n,0);-        return lhc_malloc_basic(n);-}--#undef lhc_malloc_atomic-static inline void * A_MALLOC-lhc_malloc_atomic(size_t n) {-        alloc_count(n,1);-        return lhc_malloc_basic(n);-}---#endif /* _LHC_DEBUG */--#endif /* _LHC_GC == _LHC_GC_BOEHM */----
− data/rts/lhc_rts_header.h 
@@ -1,79 +0,0 @@--// lhc_rts_header.h--#include <stdlib.h>-#include <stdio.h>-#include <string.h>-#include <unistd.h>-#include <wchar.h>-#include <limits.h>-#include <locale.h>-#include <math.h>-#include <assert.h>-#include <float.h>-#include <sys/times.h>-#include <setjmp.h>---// #define our options--#define _LHC_GC_NONE  0-#define _LHC_GC_BOEHM 1---#ifndef _LHC_GC-#define _LHC_GC _LHC_GC_NONE-#endif--#ifndef _LHC_PROFILE-#define _LHC_PROFILE 0-#endif--#ifndef _LHC_DEBUG-#ifdef NDEBUG-#define _LHC_DEBUG 0-#else-#define _LHC_DEBUG 1-#endif-#endif---// GNU attributes--#ifdef __GNUC__-#define A_ALIGNED  __attribute__ ((aligned))-#define A_CONST    __attribute__ ((const))-#define A_MALLOC   __attribute__ ((malloc))-#define A_MAYALIAS __attribute__ ((__may_alias__))-#define A_NORETURN __attribute__ ((noreturn))-#define A_PURE     __attribute__ ((pure))-#define A_UNUSED   __attribute__ ((unused))-#ifdef __i386__-#define A_REGPARM __attribute__ ((fastcall))-#else-#define A_REGPARM-#endif-#define A_STD    A_REGPARM--#else-#define A_ALIGNED-#define A_CONST-#define A_MALLOC-#define A_MAYALIAS-#define A_NORETURN-#define A_PURE-#define A_UNUSED-#define A_STD-#endif--// these should be enabled with newer versions of gcc-#define A_HOT-#define A_COLD-#define A_FALIGNED--#define STR(s) #s-#define XSTR(s) STR(s)-#define ALIGN(a,n) ((n) - 1 + ((a) - ((n) - 1) % (a)))---
− data/wsize.h 
@@ -1,67 +0,0 @@-#ifndef WSIZE_H-#define WSIZE_H--/*- * wsize.h- * define appropriate __WORDSIZE and __BYTE_ORDER macros- *- * always use operating systems headers rather than checking for architectures- * when possible. if adding new cases. Checking the CPU type should be a last- * resort.- *- */--#include <limits.h>--#ifdef __linux__-#include<endian.h>-#endif--#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-#ifdef _BIG_ENDIAN-#define __BYTE_ORDER __BIG_ENDIAN-#elif defined(_LITTLE_ENDIAN)-#define __BYTE_ORDER __LITTLE_ENDIAN-#elif defined(__i386__)-#define __BYTE_ORDER __LITTLE_ENDIAN-#else-#error Could not determine Byte Order-#endif-#endif--#ifndef __WORDSIZE-#ifdef WORD_BIT-#define __WORDSIZE WORD_BIT-#elif defined(__i386__)-#define __WORDSIZE 32-#elif defined(__x86_64__)-#define __WORDSIZE 64-#else-#error Could not determine bitsize-#endif--#endif---#ifdef TEST_WSIZE-#include <stdio.h>-int-main(int argc, char *argv[])-{-    printf("__WORDSIZE:   %i\n", __WORDSIZE);-    printf("__BYTE_ORDER: %i\n", __BYTE_ORDER);-    return 0;-}-#endif--#endif
− dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs 
@@ -1,4718 +0,0 @@-{-# OPTIONS -fglasgow-exts -cpp #-}-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 Control.Monad (liftM, liftM2)-import Debug.Trace (trace)-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-#else-import Array-#endif-#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts-#else-import GlaExts-#endif---- parser produced by Happy Version 1.18.2--newtype HappyAbsSyn  = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = GHC.Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn5 :: (HsModule) -> (HappyAbsSyn )-happyIn5 x = unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> (HsModule)-happyOut5 x = unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: (HsModule) -> (HappyAbsSyn )-happyIn6 x = unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> (HsModule)-happyOut6 x = unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: (([HsImportDecl],[HsDecl])) -> (HappyAbsSyn )-happyIn7 x = unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> (([HsImportDecl],[HsDecl]))-happyOut7 x = unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: (([HsImportDecl],[HsDecl])) -> (HappyAbsSyn )-happyIn8 x = unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> (([HsImportDecl],[HsDecl]))-happyOut8 x = unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: (()) -> (HappyAbsSyn )-happyIn9 x = unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> (())-happyOut9 x = unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: (Maybe [HsExportSpec]) -> (HappyAbsSyn )-happyIn10 x = unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> (Maybe [HsExportSpec])-happyOut10 x = unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: ([HsExportSpec]) -> (HappyAbsSyn )-happyIn11 x = unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> ([HsExportSpec])-happyOut11 x = unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: (()) -> (HappyAbsSyn )-happyIn12 x = unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> (())-happyOut12 x = unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyIn13 :: ([HsExportSpec]) -> (HappyAbsSyn )-happyIn13 x = unsafeCoerce# x-{-# INLINE happyIn13 #-}-happyOut13 :: (HappyAbsSyn ) -> ([HsExportSpec])-happyOut13 x = unsafeCoerce# x-{-# INLINE happyOut13 #-}-happyIn14 :: (HsExportSpec) -> (HappyAbsSyn )-happyIn14 x = unsafeCoerce# x-{-# INLINE happyIn14 #-}-happyOut14 :: (HappyAbsSyn ) -> (HsExportSpec)-happyOut14 x = unsafeCoerce# x-{-# INLINE happyOut14 #-}-happyIn15 :: ([HsName]) -> (HappyAbsSyn )-happyIn15 x = unsafeCoerce# x-{-# INLINE happyIn15 #-}-happyOut15 :: (HappyAbsSyn ) -> ([HsName])-happyOut15 x = unsafeCoerce# x-{-# INLINE happyOut15 #-}-happyIn16 :: (HsName) -> (HappyAbsSyn )-happyIn16 x = unsafeCoerce# x-{-# INLINE happyIn16 #-}-happyOut16 :: (HappyAbsSyn ) -> (HsName)-happyOut16 x = unsafeCoerce# x-{-# INLINE happyOut16 #-}-happyIn17 :: ([HsImportDecl]) -> (HappyAbsSyn )-happyIn17 x = unsafeCoerce# x-{-# INLINE happyIn17 #-}-happyOut17 :: (HappyAbsSyn ) -> ([HsImportDecl])-happyOut17 x = unsafeCoerce# x-{-# INLINE happyOut17 #-}-happyIn18 :: (HsImportDecl) -> (HappyAbsSyn )-happyIn18 x = unsafeCoerce# x-{-# INLINE happyIn18 #-}-happyOut18 :: (HappyAbsSyn ) -> (HsImportDecl)-happyOut18 x = unsafeCoerce# x-{-# INLINE happyOut18 #-}-happyIn19 :: (Bool) -> (HappyAbsSyn )-happyIn19 x = unsafeCoerce# x-{-# INLINE happyIn19 #-}-happyOut19 :: (HappyAbsSyn ) -> (Bool)-happyOut19 x = unsafeCoerce# x-{-# INLINE happyOut19 #-}-happyIn20 :: (Maybe Module) -> (HappyAbsSyn )-happyIn20 x = unsafeCoerce# x-{-# INLINE happyIn20 #-}-happyOut20 :: (HappyAbsSyn ) -> (Maybe Module)-happyOut20 x = unsafeCoerce# x-{-# INLINE happyOut20 #-}-happyIn21 :: (Maybe (Bool, [HsImportSpec])) -> (HappyAbsSyn )-happyIn21 x = unsafeCoerce# x-{-# INLINE happyIn21 #-}-happyOut21 :: (HappyAbsSyn ) -> (Maybe (Bool, [HsImportSpec]))-happyOut21 x = unsafeCoerce# x-{-# INLINE happyOut21 #-}-happyIn22 :: ((Bool, [HsImportSpec])) -> (HappyAbsSyn )-happyIn22 x = unsafeCoerce# x-{-# INLINE happyIn22 #-}-happyOut22 :: (HappyAbsSyn ) -> ((Bool, [HsImportSpec]))-happyOut22 x = unsafeCoerce# x-{-# INLINE happyOut22 #-}-happyIn23 :: ([HsImportSpec]) -> (HappyAbsSyn )-happyIn23 x = unsafeCoerce# x-{-# INLINE happyIn23 #-}-happyOut23 :: (HappyAbsSyn ) -> ([HsImportSpec])-happyOut23 x = unsafeCoerce# x-{-# INLINE happyOut23 #-}-happyIn24 :: (HsImportSpec) -> (HappyAbsSyn )-happyIn24 x = unsafeCoerce# x-{-# INLINE happyIn24 #-}-happyOut24 :: (HappyAbsSyn ) -> (HsImportSpec)-happyOut24 x = unsafeCoerce# x-{-# INLINE happyOut24 #-}-happyIn25 :: ([HsName]) -> (HappyAbsSyn )-happyIn25 x = unsafeCoerce# x-{-# INLINE happyIn25 #-}-happyOut25 :: (HappyAbsSyn ) -> ([HsName])-happyOut25 x = unsafeCoerce# x-{-# INLINE happyOut25 #-}-happyIn26 :: (HsName) -> (HappyAbsSyn )-happyIn26 x = unsafeCoerce# x-{-# INLINE happyIn26 #-}-happyOut26 :: (HappyAbsSyn ) -> (HsName)-happyOut26 x = unsafeCoerce# x-{-# INLINE happyOut26 #-}-happyIn27 :: (HsDecl) -> (HappyAbsSyn )-happyIn27 x = unsafeCoerce# x-{-# INLINE happyIn27 #-}-happyOut27 :: (HappyAbsSyn ) -> (HsDecl)-happyOut27 x = unsafeCoerce# x-{-# INLINE happyOut27 #-}-happyIn28 :: (Int) -> (HappyAbsSyn )-happyIn28 x = unsafeCoerce# x-{-# INLINE happyIn28 #-}-happyOut28 :: (HappyAbsSyn ) -> (Int)-happyOut28 x = unsafeCoerce# x-{-# INLINE happyOut28 #-}-happyIn29 :: (HsAssoc) -> (HappyAbsSyn )-happyIn29 x = unsafeCoerce# x-{-# INLINE happyIn29 #-}-happyOut29 :: (HappyAbsSyn ) -> (HsAssoc)-happyOut29 x = unsafeCoerce# x-{-# INLINE happyOut29 #-}-happyIn30 :: ([HsName]) -> (HappyAbsSyn )-happyIn30 x = unsafeCoerce# x-{-# INLINE happyIn30 #-}-happyOut30 :: (HappyAbsSyn ) -> ([HsName])-happyOut30 x = unsafeCoerce# x-{-# INLINE happyOut30 #-}-happyIn31 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn31 x = unsafeCoerce# x-{-# INLINE happyIn31 #-}-happyOut31 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut31 x = unsafeCoerce# x-{-# INLINE happyOut31 #-}-happyIn32 :: (HsDecl) -> (HappyAbsSyn )-happyIn32 x = unsafeCoerce# x-{-# INLINE happyIn32 #-}-happyOut32 :: (HappyAbsSyn ) -> (HsDecl)-happyOut32 x = unsafeCoerce# x-{-# INLINE happyOut32 #-}-happyIn33 :: (HsRule) -> (HappyAbsSyn )-happyIn33 x = unsafeCoerce# x-{-# INLINE happyIn33 #-}-happyOut33 :: (HappyAbsSyn ) -> (HsRule)-happyOut33 x = unsafeCoerce# x-{-# INLINE happyOut33 #-}-happyIn34 :: ([HsRule]) -> (HappyAbsSyn )-happyIn34 x = unsafeCoerce# x-{-# INLINE happyIn34 #-}-happyOut34 :: (HappyAbsSyn ) -> ([HsRule])-happyOut34 x = unsafeCoerce# x-{-# INLINE happyOut34 #-}-happyIn35 :: ([HsRule]) -> (HappyAbsSyn )-happyIn35 x = unsafeCoerce# x-{-# INLINE happyIn35 #-}-happyOut35 :: (HappyAbsSyn ) -> ([HsRule])-happyOut35 x = unsafeCoerce# x-{-# INLINE happyOut35 #-}-happyIn36 :: ([(HsName,Maybe HsType)]) -> (HappyAbsSyn )-happyIn36 x = unsafeCoerce# x-{-# INLINE happyIn36 #-}-happyOut36 :: (HappyAbsSyn ) -> ([(HsName,Maybe HsType)])-happyOut36 x = unsafeCoerce# x-{-# INLINE happyOut36 #-}-happyIn37 :: ([(HsName,Maybe HsType)]) -> (HappyAbsSyn )-happyIn37 x = unsafeCoerce# x-{-# INLINE happyIn37 #-}-happyOut37 :: (HappyAbsSyn ) -> ([(HsName,Maybe HsType)])-happyOut37 x = unsafeCoerce# x-{-# INLINE happyOut37 #-}-happyIn38 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn38 x = unsafeCoerce# x-{-# INLINE happyIn38 #-}-happyOut38 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut38 x = unsafeCoerce# x-{-# INLINE happyOut38 #-}-happyIn39 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn39 x = unsafeCoerce# x-{-# INLINE happyIn39 #-}-happyOut39 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut39 x = unsafeCoerce# x-{-# INLINE happyOut39 #-}-happyIn40 :: (HsDecl) -> (HappyAbsSyn )-happyIn40 x = unsafeCoerce# x-{-# INLINE happyIn40 #-}-happyOut40 :: (HappyAbsSyn ) -> (HsDecl)-happyOut40 x = unsafeCoerce# x-{-# INLINE happyOut40 #-}-happyIn41 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn41 x = unsafeCoerce# x-{-# INLINE happyIn41 #-}-happyOut41 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut41 x = unsafeCoerce# x-{-# INLINE happyOut41 #-}-happyIn42 :: (HsDecl) -> (HappyAbsSyn )-happyIn42 x = unsafeCoerce# x-{-# INLINE happyIn42 #-}-happyOut42 :: (HappyAbsSyn ) -> (HsDecl)-happyOut42 x = unsafeCoerce# x-{-# INLINE happyOut42 #-}-happyIn43 :: (HsDecl) -> (HappyAbsSyn )-happyIn43 x = unsafeCoerce# x-{-# INLINE happyIn43 #-}-happyOut43 :: (HappyAbsSyn ) -> (HsDecl)-happyOut43 x = unsafeCoerce# x-{-# INLINE happyOut43 #-}-happyIn44 :: ([HsName]) -> (HappyAbsSyn )-happyIn44 x = unsafeCoerce# x-{-# INLINE happyIn44 #-}-happyOut44 :: (HappyAbsSyn ) -> ([HsName])-happyOut44 x = unsafeCoerce# x-{-# INLINE happyOut44 #-}-happyIn45 :: (Maybe (String,HsName)) -> (HappyAbsSyn )-happyIn45 x = unsafeCoerce# x-{-# INLINE happyIn45 #-}-happyOut45 :: (HappyAbsSyn ) -> (Maybe (String,HsName))-happyOut45 x = unsafeCoerce# x-{-# INLINE happyOut45 #-}-happyIn46 :: (HsType) -> (HappyAbsSyn )-happyIn46 x = unsafeCoerce# x-{-# INLINE happyIn46 #-}-happyOut46 :: (HappyAbsSyn ) -> (HsType)-happyOut46 x = unsafeCoerce# x-{-# INLINE happyOut46 #-}-happyIn47 :: ([HsTyVarBind]) -> (HappyAbsSyn )-happyIn47 x = unsafeCoerce# x-{-# INLINE happyIn47 #-}-happyOut47 :: (HappyAbsSyn ) -> ([HsTyVarBind])-happyOut47 x = unsafeCoerce# x-{-# INLINE happyOut47 #-}-happyIn48 :: (HsTyVarBind) -> (HappyAbsSyn )-happyIn48 x = unsafeCoerce# x-{-# INLINE happyIn48 #-}-happyOut48 :: (HappyAbsSyn ) -> (HsTyVarBind)-happyOut48 x = unsafeCoerce# x-{-# INLINE happyOut48 #-}-happyIn49 :: (HsKind) -> (HappyAbsSyn )-happyIn49 x = unsafeCoerce# x-{-# INLINE happyIn49 #-}-happyOut49 :: (HappyAbsSyn ) -> (HsKind)-happyOut49 x = unsafeCoerce# x-{-# INLINE happyOut49 #-}-happyIn50 :: (HsKind) -> (HappyAbsSyn )-happyIn50 x = unsafeCoerce# x-{-# INLINE happyIn50 #-}-happyOut50 :: (HappyAbsSyn ) -> (HsKind)-happyOut50 x = unsafeCoerce# x-{-# INLINE happyOut50 #-}-happyIn51 :: (HsType) -> (HappyAbsSyn )-happyIn51 x = unsafeCoerce# x-{-# INLINE happyIn51 #-}-happyOut51 :: (HappyAbsSyn ) -> (HsType)-happyOut51 x = unsafeCoerce# x-{-# INLINE happyOut51 #-}-happyIn52 :: (HsType) -> (HappyAbsSyn )-happyIn52 x = unsafeCoerce# x-{-# INLINE happyIn52 #-}-happyOut52 :: (HappyAbsSyn ) -> (HsType)-happyOut52 x = unsafeCoerce# x-{-# INLINE happyOut52 #-}-happyIn53 :: (HsType) -> (HappyAbsSyn )-happyIn53 x = unsafeCoerce# x-{-# INLINE happyIn53 #-}-happyOut53 :: (HappyAbsSyn ) -> (HsType)-happyOut53 x = unsafeCoerce# x-{-# INLINE happyOut53 #-}-happyIn54 :: (HsName) -> (HappyAbsSyn )-happyIn54 x = unsafeCoerce# x-{-# INLINE happyIn54 #-}-happyOut54 :: (HappyAbsSyn ) -> (HsName)-happyOut54 x = unsafeCoerce# x-{-# INLINE happyOut54 #-}-happyIn55 :: (HsQualType) -> (HappyAbsSyn )-happyIn55 x = unsafeCoerce# x-{-# INLINE happyIn55 #-}-happyOut55 :: (HappyAbsSyn ) -> (HsQualType)-happyOut55 x = unsafeCoerce# x-{-# INLINE happyOut55 #-}-happyIn56 :: ((HsContext, HsContext)) -> (HappyAbsSyn )-happyIn56 x = unsafeCoerce# x-{-# INLINE happyIn56 #-}-happyOut56 :: (HappyAbsSyn ) -> ((HsContext, HsContext))-happyOut56 x = unsafeCoerce# x-{-# INLINE happyOut56 #-}-happyIn57 :: (HsClassHead) -> (HappyAbsSyn )-happyIn57 x = unsafeCoerce# x-{-# INLINE happyIn57 #-}-happyOut57 :: (HappyAbsSyn ) -> (HsClassHead)-happyOut57 x = unsafeCoerce# x-{-# INLINE happyOut57 #-}-happyIn58 :: ([HsType]) -> (HappyAbsSyn )-happyIn58 x = unsafeCoerce# x-{-# INLINE happyIn58 #-}-happyOut58 :: (HappyAbsSyn ) -> ([HsType])-happyOut58 x = unsafeCoerce# x-{-# INLINE happyOut58 #-}-happyIn59 :: ((HsName, [HsType])) -> (HappyAbsSyn )-happyIn59 x = unsafeCoerce# x-{-# INLINE happyIn59 #-}-happyOut59 :: (HappyAbsSyn ) -> ((HsName, [HsType]))-happyOut59 x = unsafeCoerce# x-{-# INLINE happyOut59 #-}-happyIn60 :: ([HsType]) -> (HappyAbsSyn )-happyIn60 x = unsafeCoerce# x-{-# INLINE happyIn60 #-}-happyOut60 :: (HappyAbsSyn ) -> ([HsType])-happyOut60 x = unsafeCoerce# x-{-# INLINE happyOut60 #-}-happyIn61 :: ([HsConDecl]) -> (HappyAbsSyn )-happyIn61 x = unsafeCoerce# x-{-# INLINE happyIn61 #-}-happyOut61 :: (HappyAbsSyn ) -> ([HsConDecl])-happyOut61 x = unsafeCoerce# x-{-# INLINE happyOut61 #-}-happyIn62 :: (HsConDecl) -> (HappyAbsSyn )-happyIn62 x = unsafeCoerce# x-{-# INLINE happyIn62 #-}-happyOut62 :: (HappyAbsSyn ) -> (HsConDecl)-happyOut62 x = unsafeCoerce# x-{-# INLINE happyOut62 #-}-happyIn63 :: ([HsTyVarBind]) -> (HappyAbsSyn )-happyIn63 x = unsafeCoerce# x-{-# INLINE happyIn63 #-}-happyOut63 :: (HappyAbsSyn ) -> ([HsTyVarBind])-happyOut63 x = unsafeCoerce# x-{-# INLINE happyOut63 #-}-happyIn64 :: ((HsName, [HsBangType])) -> (HappyAbsSyn )-happyIn64 x = unsafeCoerce# x-{-# INLINE happyIn64 #-}-happyOut64 :: (HappyAbsSyn ) -> ((HsName, [HsBangType]))-happyOut64 x = unsafeCoerce# x-{-# INLINE happyOut64 #-}-happyIn65 :: ((HsName, [HsBangType])) -> (HappyAbsSyn )-happyIn65 x = unsafeCoerce# x-{-# INLINE happyIn65 #-}-happyOut65 :: (HappyAbsSyn ) -> ((HsName, [HsBangType]))-happyOut65 x = unsafeCoerce# x-{-# INLINE happyOut65 #-}-happyIn66 :: (HsBangType) -> (HappyAbsSyn )-happyIn66 x = unsafeCoerce# x-{-# INLINE happyIn66 #-}-happyOut66 :: (HappyAbsSyn ) -> (HsBangType)-happyOut66 x = unsafeCoerce# x-{-# INLINE happyOut66 #-}-happyIn67 :: (HsBangType) -> (HappyAbsSyn )-happyIn67 x = unsafeCoerce# x-{-# INLINE happyIn67 #-}-happyOut67 :: (HappyAbsSyn ) -> (HsBangType)-happyOut67 x = unsafeCoerce# x-{-# INLINE happyOut67 #-}-happyIn68 :: ([([HsName],HsBangType)]) -> (HappyAbsSyn )-happyIn68 x = unsafeCoerce# x-{-# INLINE happyIn68 #-}-happyOut68 :: (HappyAbsSyn ) -> ([([HsName],HsBangType)])-happyOut68 x = unsafeCoerce# x-{-# INLINE happyOut68 #-}-happyIn69 :: (([HsName],HsBangType)) -> (HappyAbsSyn )-happyIn69 x = unsafeCoerce# x-{-# INLINE happyIn69 #-}-happyOut69 :: (HappyAbsSyn ) -> (([HsName],HsBangType))-happyOut69 x = unsafeCoerce# x-{-# INLINE happyOut69 #-}-happyIn70 :: (HsBangType) -> (HappyAbsSyn )-happyIn70 x = unsafeCoerce# x-{-# INLINE happyIn70 #-}-happyOut70 :: (HappyAbsSyn ) -> (HsBangType)-happyOut70 x = unsafeCoerce# x-{-# INLINE happyOut70 #-}-happyIn71 :: ([HsName]) -> (HappyAbsSyn )-happyIn71 x = unsafeCoerce# x-{-# INLINE happyIn71 #-}-happyOut71 :: (HappyAbsSyn ) -> ([HsName])-happyOut71 x = unsafeCoerce# x-{-# INLINE happyOut71 #-}-happyIn72 :: ([HsName]) -> (HappyAbsSyn )-happyIn72 x = unsafeCoerce# x-{-# INLINE happyIn72 #-}-happyOut72 :: (HappyAbsSyn ) -> ([HsName])-happyOut72 x = unsafeCoerce# x-{-# INLINE happyOut72 #-}-happyIn73 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn73 x = unsafeCoerce# x-{-# INLINE happyIn73 #-}-happyOut73 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut73 x = unsafeCoerce# x-{-# INLINE happyOut73 #-}-happyIn74 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn74 x = unsafeCoerce# x-{-# INLINE happyIn74 #-}-happyOut74 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut74 x = unsafeCoerce# x-{-# INLINE happyOut74 #-}-happyIn75 :: ([([HsName],[HsName])]) -> (HappyAbsSyn )-happyIn75 x = unsafeCoerce# x-{-# INLINE happyIn75 #-}-happyOut75 :: (HappyAbsSyn ) -> ([([HsName],[HsName])])-happyOut75 x = unsafeCoerce# x-{-# INLINE happyOut75 #-}-happyIn76 :: ([([HsName],[HsName])]) -> (HappyAbsSyn )-happyIn76 x = unsafeCoerce# x-{-# INLINE happyIn76 #-}-happyOut76 :: (HappyAbsSyn ) -> ([([HsName],[HsName])])-happyOut76 x = unsafeCoerce# x-{-# INLINE happyOut76 #-}-happyIn77 :: (([HsName],[HsName])) -> (HappyAbsSyn )-happyIn77 x = unsafeCoerce# x-{-# INLINE happyIn77 #-}-happyOut77 :: (HappyAbsSyn ) -> (([HsName],[HsName]))-happyOut77 x = unsafeCoerce# x-{-# INLINE happyOut77 #-}-happyIn78 :: ([HsName]) -> (HappyAbsSyn )-happyIn78 x = unsafeCoerce# x-{-# INLINE happyIn78 #-}-happyOut78 :: (HappyAbsSyn ) -> ([HsName])-happyOut78 x = unsafeCoerce# x-{-# INLINE happyOut78 #-}-happyIn79 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn79 x = unsafeCoerce# x-{-# INLINE happyIn79 #-}-happyOut79 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut79 x = unsafeCoerce# x-{-# INLINE happyOut79 #-}-happyIn80 :: ([HsDecl]) -> (HappyAbsSyn )-happyIn80 x = unsafeCoerce# x-{-# INLINE happyIn80 #-}-happyOut80 :: (HappyAbsSyn ) -> ([HsDecl])-happyOut80 x = unsafeCoerce# x-{-# INLINE happyOut80 #-}-happyIn81 :: (HsDecl) -> (HappyAbsSyn )-happyIn81 x = unsafeCoerce# x-{-# INLINE happyIn81 #-}-happyOut81 :: (HappyAbsSyn ) -> (HsDecl)-happyOut81 x = unsafeCoerce# x-{-# INLINE happyOut81 #-}-happyIn82 :: (HsRhs) -> (HappyAbsSyn )-happyIn82 x = unsafeCoerce# x-{-# INLINE happyIn82 #-}-happyOut82 :: (HappyAbsSyn ) -> (HsRhs)-happyOut82 x = unsafeCoerce# x-{-# INLINE happyOut82 #-}-happyIn83 :: ([HsGuardedRhs]) -> (HappyAbsSyn )-happyIn83 x = unsafeCoerce# x-{-# INLINE happyIn83 #-}-happyOut83 :: (HappyAbsSyn ) -> ([HsGuardedRhs])-happyOut83 x = unsafeCoerce# x-{-# INLINE happyOut83 #-}-happyIn84 :: (HsGuardedRhs) -> (HappyAbsSyn )-happyIn84 x = unsafeCoerce# x-{-# INLINE happyIn84 #-}-happyOut84 :: (HappyAbsSyn ) -> (HsGuardedRhs)-happyOut84 x = unsafeCoerce# x-{-# INLINE happyOut84 #-}-happyIn85 :: (HsExp) -> (HappyAbsSyn )-happyIn85 x = unsafeCoerce# x-{-# INLINE happyIn85 #-}-happyOut85 :: (HappyAbsSyn ) -> (HsExp)-happyOut85 x = unsafeCoerce# x-{-# INLINE happyOut85 #-}-happyIn86 :: (HsExp) -> (HappyAbsSyn )-happyIn86 x = unsafeCoerce# x-{-# INLINE happyIn86 #-}-happyOut86 :: (HappyAbsSyn ) -> (HsExp)-happyOut86 x = unsafeCoerce# x-{-# INLINE happyOut86 #-}-happyIn87 :: (HsExp) -> (HappyAbsSyn )-happyIn87 x = unsafeCoerce# x-{-# INLINE happyIn87 #-}-happyOut87 :: (HappyAbsSyn ) -> (HsExp)-happyOut87 x = unsafeCoerce# x-{-# INLINE happyOut87 #-}-happyIn88 :: (HsExp) -> (HappyAbsSyn )-happyIn88 x = unsafeCoerce# x-{-# INLINE happyIn88 #-}-happyOut88 :: (HappyAbsSyn ) -> (HsExp)-happyOut88 x = unsafeCoerce# x-{-# INLINE happyOut88 #-}-happyIn89 :: ([HsExp]) -> (HappyAbsSyn )-happyIn89 x = unsafeCoerce# x-{-# INLINE happyIn89 #-}-happyOut89 :: (HappyAbsSyn ) -> ([HsExp])-happyOut89 x = unsafeCoerce# x-{-# INLINE happyOut89 #-}-happyIn90 :: (HsExp) -> (HappyAbsSyn )-happyIn90 x = unsafeCoerce# x-{-# INLINE happyIn90 #-}-happyOut90 :: (HappyAbsSyn ) -> (HsExp)-happyOut90 x = unsafeCoerce# x-{-# INLINE happyOut90 #-}-happyIn91 :: (HsExp) -> (HappyAbsSyn )-happyIn91 x = unsafeCoerce# x-{-# INLINE happyIn91 #-}-happyOut91 :: (HappyAbsSyn ) -> (HsExp)-happyOut91 x = unsafeCoerce# x-{-# INLINE happyOut91 #-}-happyIn92 :: (Int) -> (HappyAbsSyn )-happyIn92 x = unsafeCoerce# x-{-# INLINE happyIn92 #-}-happyOut92 :: (HappyAbsSyn ) -> (Int)-happyOut92 x = unsafeCoerce# x-{-# INLINE happyOut92 #-}-happyIn93 :: ([HsExp]) -> (HappyAbsSyn )-happyIn93 x = unsafeCoerce# x-{-# INLINE happyIn93 #-}-happyOut93 :: (HappyAbsSyn ) -> ([HsExp])-happyOut93 x = unsafeCoerce# x-{-# INLINE happyOut93 #-}-happyIn94 :: (HsExp) -> (HappyAbsSyn )-happyIn94 x = unsafeCoerce# x-{-# INLINE happyIn94 #-}-happyOut94 :: (HappyAbsSyn ) -> (HsExp)-happyOut94 x = unsafeCoerce# x-{-# INLINE happyOut94 #-}-happyIn95 :: ([HsExp]) -> (HappyAbsSyn )-happyIn95 x = unsafeCoerce# x-{-# INLINE happyIn95 #-}-happyOut95 :: (HappyAbsSyn ) -> ([HsExp])-happyOut95 x = unsafeCoerce# x-{-# INLINE happyOut95 #-}-happyIn96 :: ([HsStmt]) -> (HappyAbsSyn )-happyIn96 x = unsafeCoerce# x-{-# INLINE happyIn96 #-}-happyOut96 :: (HappyAbsSyn ) -> ([HsStmt])-happyOut96 x = unsafeCoerce# x-{-# INLINE happyOut96 #-}-happyIn97 :: (HsStmt) -> (HappyAbsSyn )-happyIn97 x = unsafeCoerce# x-{-# INLINE happyIn97 #-}-happyOut97 :: (HappyAbsSyn ) -> (HsStmt)-happyOut97 x = unsafeCoerce# x-{-# INLINE happyOut97 #-}-happyIn98 :: ([HsAlt]) -> (HappyAbsSyn )-happyIn98 x = unsafeCoerce# x-{-# INLINE happyIn98 #-}-happyOut98 :: (HappyAbsSyn ) -> ([HsAlt])-happyOut98 x = unsafeCoerce# x-{-# INLINE happyOut98 #-}-happyIn99 :: ([HsAlt]) -> (HappyAbsSyn )-happyIn99 x = unsafeCoerce# x-{-# INLINE happyIn99 #-}-happyOut99 :: (HappyAbsSyn ) -> ([HsAlt])-happyOut99 x = unsafeCoerce# x-{-# INLINE happyOut99 #-}-happyIn100 :: (HsAlt) -> (HappyAbsSyn )-happyIn100 x = unsafeCoerce# x-{-# INLINE happyIn100 #-}-happyOut100 :: (HappyAbsSyn ) -> (HsAlt)-happyOut100 x = unsafeCoerce# x-{-# INLINE happyOut100 #-}-happyIn101 :: (HsRhs) -> (HappyAbsSyn )-happyIn101 x = unsafeCoerce# x-{-# INLINE happyIn101 #-}-happyOut101 :: (HappyAbsSyn ) -> (HsRhs)-happyOut101 x = unsafeCoerce# x-{-# INLINE happyOut101 #-}-happyIn102 :: ([HsGuardedRhs]) -> (HappyAbsSyn )-happyIn102 x = unsafeCoerce# x-{-# INLINE happyIn102 #-}-happyOut102 :: (HappyAbsSyn ) -> ([HsGuardedRhs])-happyOut102 x = unsafeCoerce# x-{-# INLINE happyOut102 #-}-happyIn103 :: (HsGuardedRhs) -> (HappyAbsSyn )-happyIn103 x = unsafeCoerce# x-{-# INLINE happyIn103 #-}-happyOut103 :: (HappyAbsSyn ) -> (HsGuardedRhs)-happyOut103 x = unsafeCoerce# x-{-# INLINE happyOut103 #-}-happyIn104 :: ([HsStmt]) -> (HappyAbsSyn )-happyIn104 x = unsafeCoerce# x-{-# INLINE happyIn104 #-}-happyOut104 :: (HappyAbsSyn ) -> ([HsStmt])-happyOut104 x = unsafeCoerce# x-{-# INLINE happyOut104 #-}-happyIn105 :: ([HsStmt]) -> (HappyAbsSyn )-happyIn105 x = unsafeCoerce# x-{-# INLINE happyIn105 #-}-happyOut105 :: (HappyAbsSyn ) -> ([HsStmt])-happyOut105 x = unsafeCoerce# x-{-# INLINE happyOut105 #-}-happyIn106 :: ([HsStmt]) -> (HappyAbsSyn )-happyIn106 x = unsafeCoerce# x-{-# INLINE happyIn106 #-}-happyOut106 :: (HappyAbsSyn ) -> ([HsStmt])-happyOut106 x = unsafeCoerce# x-{-# INLINE happyOut106 #-}-happyIn107 :: ([HsFieldUpdate]) -> (HappyAbsSyn )-happyIn107 x = unsafeCoerce# x-{-# INLINE happyIn107 #-}-happyOut107 :: (HappyAbsSyn ) -> ([HsFieldUpdate])-happyOut107 x = unsafeCoerce# x-{-# INLINE happyOut107 #-}-happyIn108 :: (HsFieldUpdate) -> (HappyAbsSyn )-happyIn108 x = unsafeCoerce# x-{-# INLINE happyIn108 #-}-happyOut108 :: (HappyAbsSyn ) -> (HsFieldUpdate)-happyOut108 x = unsafeCoerce# x-{-# INLINE happyOut108 #-}-happyIn109 :: (HsExp) -> (HappyAbsSyn )-happyIn109 x = unsafeCoerce# x-{-# INLINE happyIn109 #-}-happyOut109 :: (HappyAbsSyn ) -> (HsExp)-happyOut109 x = unsafeCoerce# x-{-# INLINE happyOut109 #-}-happyIn110 :: (HsName) -> (HappyAbsSyn )-happyIn110 x = unsafeCoerce# x-{-# INLINE happyIn110 #-}-happyOut110 :: (HappyAbsSyn ) -> (HsName)-happyOut110 x = unsafeCoerce# x-{-# INLINE happyOut110 #-}-happyIn111 :: (HsName) -> (HappyAbsSyn )-happyIn111 x = unsafeCoerce# x-{-# INLINE happyIn111 #-}-happyOut111 :: (HappyAbsSyn ) -> (HsName)-happyOut111 x = unsafeCoerce# x-{-# INLINE happyOut111 #-}-happyIn112 :: (HsName) -> (HappyAbsSyn )-happyIn112 x = unsafeCoerce# x-{-# INLINE happyIn112 #-}-happyOut112 :: (HappyAbsSyn ) -> (HsName)-happyOut112 x = unsafeCoerce# x-{-# INLINE happyOut112 #-}-happyIn113 :: (HsName) -> (HappyAbsSyn )-happyIn113 x = unsafeCoerce# x-{-# INLINE happyIn113 #-}-happyOut113 :: (HappyAbsSyn ) -> (HsName)-happyOut113 x = unsafeCoerce# x-{-# INLINE happyOut113 #-}-happyIn114 :: (HsName) -> (HappyAbsSyn )-happyIn114 x = unsafeCoerce# x-{-# INLINE happyIn114 #-}-happyOut114 :: (HappyAbsSyn ) -> (HsName)-happyOut114 x = unsafeCoerce# x-{-# INLINE happyOut114 #-}-happyIn115 :: (HsName) -> (HappyAbsSyn )-happyIn115 x = unsafeCoerce# x-{-# INLINE happyIn115 #-}-happyOut115 :: (HappyAbsSyn ) -> (HsName)-happyOut115 x = unsafeCoerce# x-{-# INLINE happyOut115 #-}-happyIn116 :: (HsName) -> (HappyAbsSyn )-happyIn116 x = unsafeCoerce# x-{-# INLINE happyIn116 #-}-happyOut116 :: (HappyAbsSyn ) -> (HsName)-happyOut116 x = unsafeCoerce# x-{-# INLINE happyOut116 #-}-happyIn117 :: (HsName) -> (HappyAbsSyn )-happyIn117 x = unsafeCoerce# x-{-# INLINE happyIn117 #-}-happyOut117 :: (HappyAbsSyn ) -> (HsName)-happyOut117 x = unsafeCoerce# x-{-# INLINE happyOut117 #-}-happyIn118 :: (HsName) -> (HappyAbsSyn )-happyIn118 x = unsafeCoerce# x-{-# INLINE happyIn118 #-}-happyOut118 :: (HappyAbsSyn ) -> (HsName)-happyOut118 x = unsafeCoerce# x-{-# INLINE happyOut118 #-}-happyIn119 :: (HsName) -> (HappyAbsSyn )-happyIn119 x = unsafeCoerce# x-{-# INLINE happyIn119 #-}-happyOut119 :: (HappyAbsSyn ) -> (HsName)-happyOut119 x = unsafeCoerce# x-{-# INLINE happyOut119 #-}-happyIn120 :: (HsExp) -> (HappyAbsSyn )-happyIn120 x = unsafeCoerce# x-{-# INLINE happyIn120 #-}-happyOut120 :: (HappyAbsSyn ) -> (HsExp)-happyOut120 x = unsafeCoerce# x-{-# INLINE happyOut120 #-}-happyIn121 :: (HsExp) -> (HappyAbsSyn )-happyIn121 x = unsafeCoerce# x-{-# INLINE happyIn121 #-}-happyOut121 :: (HappyAbsSyn ) -> (HsExp)-happyOut121 x = unsafeCoerce# x-{-# INLINE happyOut121 #-}-happyIn122 :: (HsName) -> (HappyAbsSyn )-happyIn122 x = unsafeCoerce# x-{-# INLINE happyIn122 #-}-happyOut122 :: (HappyAbsSyn ) -> (HsName)-happyOut122 x = unsafeCoerce# x-{-# INLINE happyOut122 #-}-happyIn123 :: (HsName) -> (HappyAbsSyn )-happyIn123 x = unsafeCoerce# x-{-# INLINE happyIn123 #-}-happyOut123 :: (HappyAbsSyn ) -> (HsName)-happyOut123 x = unsafeCoerce# x-{-# INLINE happyOut123 #-}-happyIn124 :: (HsName) -> (HappyAbsSyn )-happyIn124 x = unsafeCoerce# x-{-# INLINE happyIn124 #-}-happyOut124 :: (HappyAbsSyn ) -> (HsName)-happyOut124 x = unsafeCoerce# x-{-# INLINE happyOut124 #-}-happyIn125 :: (HsName) -> (HappyAbsSyn )-happyIn125 x = unsafeCoerce# x-{-# INLINE happyIn125 #-}-happyOut125 :: (HappyAbsSyn ) -> (HsName)-happyOut125 x = unsafeCoerce# x-{-# INLINE happyOut125 #-}-happyIn126 :: (HsName) -> (HappyAbsSyn )-happyIn126 x = unsafeCoerce# x-{-# INLINE happyIn126 #-}-happyOut126 :: (HappyAbsSyn ) -> (HsName)-happyOut126 x = unsafeCoerce# x-{-# INLINE happyOut126 #-}-happyIn127 :: (HsName) -> (HappyAbsSyn )-happyIn127 x = unsafeCoerce# x-{-# INLINE happyIn127 #-}-happyOut127 :: (HappyAbsSyn ) -> (HsName)-happyOut127 x = unsafeCoerce# x-{-# INLINE happyOut127 #-}-happyIn128 :: (HsName) -> (HappyAbsSyn )-happyIn128 x = unsafeCoerce# x-{-# INLINE happyIn128 #-}-happyOut128 :: (HappyAbsSyn ) -> (HsName)-happyOut128 x = unsafeCoerce# x-{-# INLINE happyOut128 #-}-happyIn129 :: (HsName) -> (HappyAbsSyn )-happyIn129 x = unsafeCoerce# x-{-# INLINE happyIn129 #-}-happyOut129 :: (HappyAbsSyn ) -> (HsName)-happyOut129 x = unsafeCoerce# x-{-# INLINE happyOut129 #-}-happyIn130 :: (HsName) -> (HappyAbsSyn )-happyIn130 x = unsafeCoerce# x-{-# INLINE happyIn130 #-}-happyOut130 :: (HappyAbsSyn ) -> (HsName)-happyOut130 x = unsafeCoerce# x-{-# INLINE happyOut130 #-}-happyIn131 :: (HsName) -> (HappyAbsSyn )-happyIn131 x = unsafeCoerce# x-{-# INLINE happyIn131 #-}-happyOut131 :: (HappyAbsSyn ) -> (HsName)-happyOut131 x = unsafeCoerce# x-{-# INLINE happyOut131 #-}-happyIn132 :: (HsName) -> (HappyAbsSyn )-happyIn132 x = unsafeCoerce# x-{-# INLINE happyIn132 #-}-happyOut132 :: (HappyAbsSyn ) -> (HsName)-happyOut132 x = unsafeCoerce# x-{-# INLINE happyOut132 #-}-happyIn133 :: (HsExp) -> (HappyAbsSyn )-happyIn133 x = unsafeCoerce# x-{-# INLINE happyIn133 #-}-happyOut133 :: (HappyAbsSyn ) -> (HsExp)-happyOut133 x = unsafeCoerce# x-{-# INLINE happyOut133 #-}-happyIn134 :: (SrcLoc) -> (HappyAbsSyn )-happyIn134 x = unsafeCoerce# x-{-# INLINE happyIn134 #-}-happyOut134 :: (HappyAbsSyn ) -> (SrcLoc)-happyOut134 x = unsafeCoerce# x-{-# INLINE happyOut134 #-}-happyIn135 :: (()) -> (HappyAbsSyn )-happyIn135 x = unsafeCoerce# x-{-# INLINE happyIn135 #-}-happyOut135 :: (HappyAbsSyn ) -> (())-happyOut135 x = unsafeCoerce# x-{-# INLINE happyOut135 #-}-happyIn136 :: (()) -> (HappyAbsSyn )-happyIn136 x = unsafeCoerce# x-{-# INLINE happyIn136 #-}-happyOut136 :: (HappyAbsSyn ) -> (())-happyOut136 x = unsafeCoerce# x-{-# INLINE happyOut136 #-}-happyIn137 :: (Module) -> (HappyAbsSyn )-happyIn137 x = unsafeCoerce# x-{-# INLINE happyIn137 #-}-happyOut137 :: (HappyAbsSyn ) -> (Module)-happyOut137 x = unsafeCoerce# x-{-# INLINE happyOut137 #-}-happyIn138 :: (HsName) -> (HappyAbsSyn )-happyIn138 x = unsafeCoerce# x-{-# INLINE happyIn138 #-}-happyOut138 :: (HappyAbsSyn ) -> (HsName)-happyOut138 x = unsafeCoerce# x-{-# INLINE happyOut138 #-}-happyIn139 :: (HsName) -> (HappyAbsSyn )-happyIn139 x = unsafeCoerce# x-{-# INLINE happyIn139 #-}-happyOut139 :: (HappyAbsSyn ) -> (HsName)-happyOut139 x = unsafeCoerce# x-{-# INLINE happyOut139 #-}-happyIn140 :: (HsName) -> (HappyAbsSyn )-happyIn140 x = unsafeCoerce# x-{-# INLINE happyIn140 #-}-happyOut140 :: (HappyAbsSyn ) -> (HsName)-happyOut140 x = unsafeCoerce# x-{-# INLINE happyOut140 #-}-happyIn141 :: (HsName) -> (HappyAbsSyn )-happyIn141 x = unsafeCoerce# x-{-# INLINE happyIn141 #-}-happyOut141 :: (HappyAbsSyn ) -> (HsName)-happyOut141 x = unsafeCoerce# x-{-# INLINE happyOut141 #-}-happyIn142 :: (HsName) -> (HappyAbsSyn )-happyIn142 x = unsafeCoerce# x-{-# INLINE happyIn142 #-}-happyOut142 :: (HappyAbsSyn ) -> (HsName)-happyOut142 x = unsafeCoerce# x-{-# INLINE happyOut142 #-}-happyInTok :: (Token) -> (HappyAbsSyn )-happyInTok x = unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Token)-happyOutTok x = unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x00\x00\xd3\x0a\x00\x00\x21\x00\x00\x00\x59\x13\x00\x00\x24\x0b\xa0\x04\x00\x00\x5f\x04\x00\x00\x89\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x04\xa9\x07\x58\x07\x46\x0b\x00\x00\x46\x0b\x00\x00\x00\x00\x82\x0a\x00\x00\xe9\x02\x00\x00\x82\x0a\xc8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x04\x12\x00\x00\x00\x00\x00\x00\x00\x2e\x04\x00\x00\x00\x00\x21\x05\xd7\x02\x6e\x04\x72\x05\x72\x05\x8c\x04\x8a\x13\xbb\x02\x00\x00\x31\x0a\x31\x0a\x58\x04\x24\x0b\x46\x0b\x46\x0b\x88\x04\xd4\x01\x85\x04\x76\x04\x00\x00\x24\x02\xf1\x01\x00\x00\xdf\x01\x8a\x13\xc5\x01\x9e\x01\x00\x00\x00\x00\xe0\x09\x87\x04\x00\x00\x84\x04\x00\x00\x00\x00\x00\x00\x83\x04\x82\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x05\x24\x0b\x81\x04\x00\x00\x00\x00\x00\x00\x7d\x04\x79\x04\x71\x04\x00\x00\x46\x0b\x29\x08\x6c\x04\x00\x00\x00\x00\xe0\x09\x00\x00\x00\x00\x00\x00\x5e\x04\x00\x00\xa1\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x0e\x63\x04\x57\x04\xe0\x09\x00\x00\xbe\x01\x00\x00\x56\x04\xca\x0e\x5d\x04\x54\x04\x00\x00\x00\x00\x6d\x13\x00\x00\xe0\x09\x00\x00\x00\x00\x07\x07\x00\x00\xe0\x09\x00\x00\x00\x00\xe0\x09\x00\x00\xe0\x09\xb6\x06\x8f\x09\x55\x04\xdd\x00\x00\x00\xae\x02\x52\x04\x00\x00\x4e\x04\x47\x04\x28\x00\x20\x04\x15\x04\x00\x00\x00\x00\x43\x04\x3b\x04\x00\x00\x00\x00\x00\x00\x3d\x04\x00\x00\x5f\x0b\x92\x01\x06\x02\x00\x00\x4f\x04\x28\x00\x3e\x09\x3c\x04\x00\x00\x00\x00\x35\x04\x33\x04\x00\x00\x30\x04\x00\x00\x00\x00\x5f\x0b\xb1\x00\xac\x02\x02\x04\x0e\x04\x52\x0e\x00\x00\x00\x00\x00\x00\x4d\x0e\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x26\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x0b\x50\x0d\x24\x0d\x6d\x09\x6d\x09\x4d\x0e\xfb\x03\x4d\x0e\x1f\x04\x4d\x0e\x4d\x0e\x00\x00\x00\x00\x2a\x04\x00\x00\x00\x00\x2c\x04\x1c\x09\x00\x00\x00\x00\x00\x00\x4a\x02\x00\x00\x7f\x04\x00\x00\x2e\x04\x00\x00\xea\x03\x00\x00\xff\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x08\x19\x02\x11\x04\x1c\x09\x00\x00\xc3\x05\x00\x00\x3e\x09\x00\x00\xed\x08\x00\x00\x00\x00\x9c\x08\x9c\x08\x00\x00\x9c\x08\x14\x04\x00\x00\x00\x00\x0a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x08\x00\x00\x29\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x06\x4b\x08\x00\x00\x5f\x0b\x0c\x04\x00\x00\x0c\x04\x0b\x04\x00\x00\x07\x04\x00\x00\x00\x00\x00\x00\xe8\x0e\x4d\x0e\xce\x03\xf8\x03\x00\x00\xfa\x07\xfa\x07\x34\x00\x00\x00\x23\x0e\xed\x03\xf7\x03\x00\x00\x00\x00\x00\x00\xf9\x03\x00\x00\xc0\x02\x7b\x02\x00\x00\xf4\x03\x00\x00\xfa\x07\xe9\x03\x92\x13\x00\x00\xf2\x03\x46\x01\xfa\x03\x36\x02\x00\x00\xfb\x0d\x01\x04\xcf\x03\x00\x00\x23\x00\x20\x00\x00\x00\xfa\x0c\x88\x02\x00\x00\xb6\x03\xc7\x03\x00\x00\xcb\x08\xc6\x03\xd5\x03\x00\x00\xe8\x01\x55\x01\x00\x00\xe0\x00\xd9\x03\x9a\x01\x51\x01\xf6\x0d\x00\x00\xd6\x03\xca\x03\x00\x00\xd1\x0d\xd1\x0d\x36\x07\x00\x00\x36\x07\xc8\x03\x00\x00\x7a\x08\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x03\x00\x00\x00\x00\xd1\x0d\x00\x00\xd1\x0d\xd1\x0d\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x0d\x00\x00\xbe\x09\xd1\x0d\x00\x00\x6e\x02\xb1\x03\x00\x00\xbc\x03\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\xba\x03\x94\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x03\x00\x00\x00\x00\xbe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x05\xd1\x0d\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x0c\xc2\x03\xa6\x0b\xcc\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x02\x00\x00\xc1\x03\x92\x03\x28\x00\xb6\x06\xb2\x03\x1e\x01\x00\x00\x00\x00\x7f\x03\xa3\x03\x00\x00\xfa\x07\xfa\x07\x00\x00\x00\x00\x00\x00\xfa\x07\x00\x00\x00\x00\xa6\x03\x00\x00\x00\x00\x00\x00\x43\x01\x00\x00\x00\x00\x00\x00\xbd\x0c\x00\x00\xaf\x03\xa9\x03\x9b\x03\x95\x03\x92\x13\xfa\x07\x00\x00\x00\x00\x9f\x0e\xa2\x03\x00\x00\xb2\x01\x00\x00\x5e\x02\x00\x00\x00\x00\x00\x00\xf7\x00\x4b\x00\x00\x00\x05\x02\x9e\x03\x20\x00\x78\x03\x1e\x00\x4d\x02\x14\x06\x14\x06\x00\x00\x8f\x03\x00\x00\x97\x03\x00\x00\x00\x00\x20\x00\x73\x03\x00\x00\xcc\x0d\x87\x03\xcc\x0d\x88\x03\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x8b\x03\x6d\x03\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x43\x06\x6f\x03\x00\x00\x00\x00\x00\x00\xa9\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x01\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\xa2\x0d\xd2\x03\x77\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x03\x00\x00\x50\x05\xfa\x07\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x6e\x03\x00\x00\x00\x00\xfa\x07\x00\x00\x6d\x0b\x00\x00\xa4\x0c\x37\x03\x00\x00\xbe\x09\x00\x00\x00\x00\xf4\x01\x00\x00\x57\x03\x45\x03\xd1\x0b\x00\x00\x7c\x0c\x18\x00\x68\x03\x60\x03\xab\x0b\xa2\x0d\xd8\x07\x55\x03\x00\x00\x00\x00\x00\x00\x5e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x65\x06\x5c\x03\xfa\x07\x00\x00\x00\x00\x00\x00\x00\x00\x98\x0e\x5a\x03\xd8\x07\x4d\x03\x00\x00\x52\x03\x87\x07\x51\x0c\x5d\x03\x00\x00\x00\x00\xa2\x0d\xa2\x0d\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x0d\x43\x03\x00\x00\xfa\x07\x00\x00\x7a\x0d\x75\x0d\x00\x00\x00\x00\x75\x0d\x00\x00\xf0\x00\xbb\x00\x00\x00\x00\x00\x51\x03\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\x00\x00\x00\x00\xac\x12\x00\x00\x47\x03\x00\x00\x00\x00\xfa\x06\x00\x00\x00\x00\x94\x06\x2b\x0c\x39\x03\x00\x00\x00\x00\x00\x00\x75\x0d\x00\x00\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x08\x00\xc6\x0f\xda\x02\x01\x00\x00\x00\x27\x0a\x00\x00\xa0\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x0e\x9d\x0f\x52\x0f\x72\x13\xd9\x02\x3c\x0e\x00\x00\x00\x00\x7e\x12\x00\x00\x0f\x00\x00\x00\x55\x12\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x94\x00\x07\x00\x00\x00\x49\x00\xd8\x02\x00\x00\x02\x01\xcb\x00\x4a\x03\x34\x06\x0d\x00\x00\x00\x0b\x0f\xed\x0e\x00\x00\xa0\x13\xeb\x09\x9b\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x05\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x02\x3c\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x13\xd1\x01\x00\x00\x00\x00\x00\x00\x01\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x01\xd0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x02\x00\x00\x00\x00\x44\x12\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x04\x00\x00\x1b\x12\x00\x00\x00\x00\x01\x13\x00\x00\x0a\x12\x00\x00\x00\x00\xe1\x11\x00\x00\xd0\x11\xa7\x11\x29\x0f\x00\x00\x00\x00\xcb\x02\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x03\x00\x00\x00\x00\x00\x00\xca\x02\x00\x00\xc6\x04\x00\x00\x21\x03\xb3\x02\xe0\xff\xb5\x02\x96\x11\x45\x00\x00\x00\x00\x00\x00\x00\x32\x03\x00\x00\x31\x03\x00\x00\x00\x00\x2d\x04\x17\x03\x0b\x00\x00\x00\xb2\x02\xce\x02\xaa\x02\xa9\x02\xa6\x02\xc4\x02\xa2\x02\x00\x00\x9c\x02\x00\x00\x00\x00\x00\x00\xd6\x02\x00\x00\xa5\x03\x00\x00\x00\x00\x93\x02\x00\x00\x00\x00\x00\x00\x37\x02\x60\x01\x6b\x03\x17\x00\x15\x00\xba\x02\x03\x03\x64\x03\x92\x02\xa0\x02\x90\x02\x91\x02\x8f\x02\x00\x00\xfe\xff\xfb\xff\xf2\x02\x75\x00\x00\x00\x00\x00\x00\x00\x31\x02\x00\x00\xb9\x01\x00\x00\x9c\x01\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x8e\x02\x00\x00\xcd\x02\x33\x00\x31\x02\x00\x00\xd3\xff\x00\x00\xd6\x01\x00\x00\x6d\x11\x00\x00\x8c\x0f\x00\x00\x00\x00\xb7\x12\x8f\x12\x00\x00\x5c\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x11\x00\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x11\x63\x0f\x00\x00\xdc\x03\xfa\x02\x00\x00\xf4\x02\x00\x00\x00\x00\xf0\x02\x00\x00\x00\x00\x00\x00\x69\x02\x83\x02\x00\x00\x95\x02\x00\x00\xf9\x10\xe8\x10\x00\x00\x00\x00\xa1\x03\x00\x00\xd5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x02\x02\x00\x00\x00\xcf\x02\x00\x00\xbf\x10\x00\x00\x65\x00\x00\x00\xcc\x02\xb9\x02\x00\x00\x05\x00\x00\x00\x37\x01\x3f\x02\x64\x02\x2f\x02\x66\x02\xa1\x01\x00\x00\x9d\x03\x21\x02\x00\x00\x59\x02\xdf\xff\x00\x00\x29\x02\xdf\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x03\x00\x00\x00\x00\x00\x00\x00\x00\x48\x03\x30\x03\x2c\x00\x4f\x02\xf1\xff\x00\x00\x00\x00\xcd\xff\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x03\x00\x00\x19\x03\x0f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x68\x02\x00\x00\x13\x02\x61\x02\x00\x00\x10\x00\x6a\x02\x03\x02\x00\x00\x00\x00\x59\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\x13\x01\x00\x00\x30\x02\xd7\x01\xf8\x01\x00\x00\x00\x00\x13\x00\x00\x00\x0b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\xf7\x02\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x2f\x00\xf3\x02\x00\x00\x00\x00\xb3\x01\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\xa2\x01\xc8\x12\x00\x00\x09\x02\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\xae\x10\x85\x10\x00\x00\x00\x00\x00\x00\x74\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x4b\x10\xed\x01\x00\x00\x1d\x01\x00\x00\x00\x00\x1d\x01\x00\x00\x09\x00\x25\x01\x00\x00\x00\x00\x4d\x01\xa9\x01\x00\x00\xab\x01\x00\x00\x90\x00\x84\x01\xbb\x01\xa2\x00\x52\x01\x2a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x76\x01\x00\x00\x54\x02\x00\x00\x44\x02\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x00\x00\x12\x01\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x03\xfc\xff\xf2\xff\x00\x00\xdc\xff\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xb8\x00\x3a\x00\x72\x03\xc7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\x3a\x10\x00\x00\x00\x00\x57\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x11\x10\x00\x00\xc1\xff\x00\x00\x86\x03\xab\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x10\x01\x00\x00\xdf\xff\xdf\xff\x86\x03\x00\x00\x4c\x03\x11\x00\x00\x00\x00\x00\x2a\x02\x80\x03\x4f\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x0e\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x9a\x00\x2d\x00\x00\x00\x00\x00\xa4\x00\x78\x02\xad\xff\x00\x00\x00\x00\x7a\x03\xb6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\xd7\x0f\x00\x00\xec\x02\xe6\x01\x00\x00\x00\x00\xe6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\xdb\x00\x04\x02\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\xa5\xfe\xa5\xfe\x00\x00\x00\x00\x02\xff\x30\xff\x2f\xff\x27\xff\x25\xff\x21\xff\x00\x00\x1f\xff\x20\xff\xe9\xfe\xe6\xfe\xd0\xfe\xe2\xfe\xc5\xfe\x1e\xff\x00\x00\xce\xfe\xcf\xfe\xc3\xfe\xc4\xfe\xac\xfe\xab\xfe\xa8\xfe\xaa\xfe\xa9\xfe\xa7\xfe\xa6\xfe\xa5\xfe\xa5\xfe\xa5\xfe\xa5\xfe\xa5\xfe\xa5\xfe\xcd\xfe\xc6\xfe\xa5\xfe\xcc\xfe\xf2\xff\xc9\xfe\xa5\xfe\xf2\xff\xca\xfe\xc8\xfe\xc7\xfe\xcb\xfe\x00\x00\xf2\xff\xfd\xff\xfa\xff\xa2\xfe\xf4\xff\xa5\xfe\xf3\xff\xa5\xfe\x00\x00\x01\xff\xf2\xff\xf2\xff\xf2\xff\x30\xff\xf2\xff\x28\xff\xa5\xfe\xa5\xfe\x00\x00\x29\xff\xa5\xfe\xa5\xfe\x23\xff\x0e\xff\x00\x00\x0d\xff\xeb\xfe\x00\x00\x00\x00\x1b\xff\x00\x00\x30\xff\x00\x00\x00\x00\xd2\xfe\xd1\xfe\xa5\xfe\xd8\xfe\xc2\xfe\x00\x00\xdc\xfe\xbf\xfe\xbd\xfe\xbc\xfe\xb2\xfe\xc0\xfe\xad\xfe\xc1\xfe\xec\xfe\x11\xff\x00\x00\xba\xfe\xb1\xfe\xb8\xfe\xb7\xfe\xb6\xfe\xb0\xfe\xaf\xfe\xae\xfe\x14\xff\xa5\xfe\x00\x00\x26\xff\xd4\xfe\xd3\xfe\xa5\xfe\xd8\xfe\xde\xfe\xbe\xfe\x00\x00\xbb\xfe\x00\x00\xa5\xfe\xba\xfe\xb9\xfe\xb5\xfe\xb4\xfe\xb3\xfe\x00\x00\x00\x00\x00\x00\xa5\xfe\x2e\xff\x00\x00\xee\xfe\x00\x00\x00\x00\x15\xff\x00\x00\xe5\xfe\xe1\xfe\x00\x00\x1c\xff\xa5\xfe\xea\xfe\x12\xff\xa5\xfe\x1d\xff\xa5\xfe\x19\xff\x1a\xff\xa5\xfe\x18\xff\xa5\xfe\x0c\xff\xa5\xfe\x24\xff\x00\x00\xa5\xfe\xf2\xff\xf2\xfe\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\xff\x9e\xff\x00\x00\xf2\xff\xa0\xff\x9f\xff\x9c\xff\xa5\xfe\x9d\xff\xa5\xfe\x20\xff\x00\x00\xa5\xfe\x00\x00\x00\x00\xa5\xfe\xf0\xff\xa1\xfe\xa0\xfe\x00\x00\xf2\xff\xde\xff\xf2\xff\xbf\xff\xae\xff\xa5\xfe\x00\x00\xf2\xff\xc6\xfe\xa5\xfe\x00\x00\xa5\xfe\xa5\xfe\xa5\xfe\x00\x00\xa5\xfe\xfc\xff\x00\x00\xf8\xff\xa3\xfe\xa4\xfe\x41\xff\x6e\xff\x92\xff\x80\xff\x7f\xff\xa5\xfe\x9b\xfe\x74\xff\x7e\xff\x00\x00\x00\x00\x00\x00\xc8\xfe\xc7\xfe\x00\x00\xdb\xff\x00\x00\xa5\xfe\xcb\xfe\x00\x00\xa5\xfe\xa5\xfe\x00\x00\xa5\xfe\xa5\xfe\xc7\xff\x00\x00\xc5\xff\xc4\xff\xc3\xff\x00\x00\xf6\xff\xf3\xff\xf5\xff\xf3\xff\xf9\xff\x00\x00\xf1\xff\x00\x00\x2c\xff\x9a\xff\xa5\xfe\x9e\xfe\x66\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa3\xff\xf3\xff\x9b\xff\xa5\xfe\xf4\xfe\xa5\xfe\xf5\xfe\x2a\xff\xa5\xfe\xa5\xfe\x13\xff\xa5\xfe\x08\xff\x04\xff\x0a\xff\x06\xff\x07\xff\x0f\xff\x17\xff\x10\xff\x16\xff\xdb\xfe\xa5\xfe\x22\xff\x00\x00\x03\xff\xd7\xfe\xdd\xfe\x31\xff\xef\xfe\xed\xfe\x0b\xff\xa5\xfe\x2d\xff\xa5\xfe\xf2\xff\xfd\xfe\xf2\xff\xf3\xfe\xf1\xfe\xf2\xff\xa1\xff\x97\xff\xe8\xfe\x00\x00\x00\x00\x38\xff\x35\xff\x33\xff\xa5\xfe\xa5\xfe\x00\x00\x96\xff\x68\xff\x39\xff\xec\xff\xea\xff\xe9\xff\x9d\xfe\xe8\xff\xee\xff\x00\x00\xf2\xff\xdf\xff\xf2\xff\xc0\xff\xa5\xfe\x00\x00\x00\x00\xc6\xff\xf2\xff\xf2\xff\x00\x00\x00\x00\xb0\xff\x00\x00\x00\x00\x46\xff\xa5\xfe\x50\xff\x00\x00\xb5\xff\x92\xff\x00\x00\xdc\xff\x3d\xff\xa5\xfe\x8e\xff\x00\x00\xa5\xfe\x00\x00\x71\xff\x00\x00\x00\x00\x7c\xff\x75\xff\x00\x00\x00\x00\x00\x00\x00\x00\x73\xff\x00\x00\x00\x00\x81\xff\x00\x00\x00\x00\x94\xff\x41\xff\x94\xff\x00\x00\x40\xff\x00\x00\x6f\xff\x93\xff\xa5\xfe\x72\xff\x00\x00\x70\xff\x7d\xff\x00\x00\x78\xff\x00\x00\x00\x00\x7a\xff\x7b\xff\x79\xff\x8f\xff\x00\x00\x8d\xff\x00\x00\x00\x00\xb7\xff\xf2\xff\xd9\xff\xa5\xfe\x8b\xff\x82\xff\x00\x00\x86\xff\x84\xff\x83\xff\x85\xff\x88\xff\x87\xff\xbe\xff\xa5\xfe\x00\x00\x00\x00\x49\xff\x41\xff\x41\xff\x6b\xff\xb6\xff\xa5\xfe\xa9\xff\xa7\xff\xaa\xff\xab\xff\xc8\xff\xd6\xfe\xd5\xfe\xc1\xff\xda\xfe\xe0\xfe\x00\x00\x00\x00\xb4\xff\xf7\xff\xfb\xff\xe4\xff\x00\x00\x00\x00\xed\xff\x00\x00\x67\xff\x98\xff\xa5\xfe\x36\xff\x34\xff\xf2\xff\x99\xff\x00\x00\x00\x00\x00\x00\xf3\xff\x00\x00\x00\x00\x05\xff\x09\xff\xfc\xfe\xf9\xfe\xf7\xfe\xa5\xfe\xa5\xfe\x00\xff\xfe\xfe\xff\xfe\xa5\xfe\xe7\xfe\x37\xff\x00\x00\x3a\xff\xeb\xff\xef\xff\x00\x00\xe2\xff\xe1\xff\xe0\xff\x00\x00\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\xfe\xa4\xff\xac\xff\x00\x00\x45\xff\x43\xff\x00\x00\xb9\xff\xf2\xff\xa5\xfe\x9c\xfe\x4f\xff\x00\x00\x50\xff\x64\xff\x5e\xff\x00\x00\x00\x00\x50\xff\xd7\xff\x00\x00\xf2\xff\xf2\xff\x90\xff\x00\x00\x91\xff\x00\x00\x69\xff\x6a\xff\x00\x00\x50\xff\x95\xff\x00\x00\x00\x00\x00\x00\xb2\xff\xba\xff\x76\xff\x77\xff\x00\x00\x3b\xff\xf2\xff\x00\x00\x47\xff\x00\x00\xda\xff\xdd\xff\xd8\xff\x00\x00\x00\x00\xbd\xff\x8a\xff\x89\xff\x00\x00\xa5\xfe\xa5\xfe\xbc\xff\xa5\xfe\x00\x00\x4b\xff\x4e\xff\x50\xff\x4a\xff\x41\xff\x41\xff\x00\x00\x00\x00\x00\x00\xc2\xff\xd9\xfe\xdf\xfe\xaf\xff\xe7\xff\x00\x00\xe5\xff\x00\x00\xa5\xfe\x2b\xff\xfa\xfe\xa5\xfe\xf8\xfe\xf2\xff\xfb\xfe\x00\x00\x32\xff\xe3\xff\xa5\xfe\xa5\xff\x00\x00\xa8\xff\x6c\xff\x49\xff\x44\xff\x42\xff\xbb\xff\x4d\xff\x00\x00\x65\xff\xa5\xfe\xa5\xfe\x5d\xff\x63\xff\x5c\xff\x00\x00\x00\x00\xc5\xfe\x00\x00\x00\x00\x00\x00\xec\xff\xd2\xff\xd1\xff\x9f\xfe\xd0\xff\xd5\xff\x3e\xff\x3f\xff\x3c\xff\xf3\xff\x00\x00\xa5\xfe\xb3\xff\xb1\xff\x8c\xff\x48\xff\x00\x00\x00\x00\xed\xff\xec\xff\x56\xff\x00\x00\x00\x00\x00\x00\x00\x00\x59\xff\x5a\xff\x00\x00\x00\x00\x5f\xff\x60\xff\x4c\xff\xb8\xff\x00\x00\x00\x00\xad\xff\xa5\xfe\xf6\xfe\x00\x00\x6d\xff\x5b\xff\x58\xff\x57\xff\x62\xff\x00\x00\x00\x00\x54\xff\xe3\xfe\x00\x00\xd3\xff\xd6\xff\x00\x00\xcb\xff\xca\xff\xc9\xff\xe4\xfe\x00\x00\xce\xff\x00\x00\xcf\xff\xcd\xff\x00\x00\xd4\xff\x61\xff\x00\x00\x00\x00\x00\x00\xa6\xff\x52\xff\x53\xff\x00\x00\x55\xff\xcc\xff\x51\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x02\x00\x02\x00\x04\x00\x04\x00\x00\x00\x00\x00\x04\x00\x2b\x00\x08\x00\x09\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x39\x00\x36\x00\x1c\x00\x1d\x00\x28\x00\x1c\x00\x1d\x00\x2a\x00\x2b\x00\x06\x00\x2c\x00\x2d\x00\x24\x00\x10\x00\x03\x00\x04\x00\x78\x00\x2a\x00\x2b\x00\x00\x00\x1e\x00\x69\x00\x19\x00\x1a\x00\x24\x00\x24\x00\x1c\x00\x69\x00\x24\x00\x24\x00\x15\x00\x07\x00\x15\x00\x69\x00\x76\x00\x09\x00\x21\x00\x19\x00\x1a\x00\x69\x00\x76\x00\x7d\x00\x2a\x00\x2b\x00\x2a\x00\x2b\x00\x76\x00\x1c\x00\x03\x00\x04\x00\x24\x00\x14\x00\x76\x00\x05\x00\x06\x00\x03\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x1f\x00\x28\x00\x0c\x00\x0d\x00\x15\x00\x78\x00\x47\x00\x27\x00\x39\x00\x3e\x00\x81\x00\x3b\x00\x16\x00\x81\x00\x12\x00\x13\x00\x1a\x00\x1b\x00\x07\x00\x86\x00\x76\x00\x47\x00\x5d\x00\x77\x00\x78\x00\x23\x00\x6a\x00\x25\x00\x26\x00\x27\x00\x26\x00\x63\x00\x81\x00\x7a\x00\x12\x00\x13\x00\x7d\x00\x75\x00\x76\x00\x77\x00\x78\x00\x81\x00\x81\x00\x19\x00\x81\x00\x83\x00\x70\x00\x48\x00\x49\x00\x83\x00\x83\x00\x3b\x00\x82\x00\x81\x00\x81\x00\x87\x00\x7a\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x81\x00\x4c\x00\x81\x00\x03\x00\x81\x00\x6a\x00\x51\x00\x52\x00\x53\x00\x6a\x00\x55\x00\x56\x00\x0c\x00\x0d\x00\x76\x00\x81\x00\x75\x00\x76\x00\x77\x00\x78\x00\x75\x00\x76\x00\x16\x00\x2c\x00\x2d\x00\x13\x00\x1a\x00\x1b\x00\x7b\x00\x68\x00\x7d\x00\x6a\x00\x7f\x00\x6c\x00\x87\x00\x23\x00\x69\x00\x25\x00\x26\x00\x27\x00\x2c\x00\x2d\x00\x75\x00\x76\x00\x77\x00\x78\x00\x76\x00\x6d\x00\x13\x00\x76\x00\x70\x00\x78\x00\x72\x00\x80\x00\x81\x00\x27\x00\x69\x00\x0a\x00\x0b\x00\x04\x00\x7a\x00\x20\x00\x6d\x00\x7d\x00\x85\x00\x70\x00\x1b\x00\x72\x00\x81\x00\x76\x00\x1f\x00\x78\x00\x15\x00\x0b\x00\x69\x00\x7a\x00\x4c\x00\x16\x00\x7d\x00\x3f\x00\x40\x00\x51\x00\x52\x00\x53\x00\x85\x00\x55\x00\x56\x00\x76\x00\x21\x00\x22\x00\x23\x00\x44\x00\x25\x00\x26\x00\x27\x00\x42\x00\x43\x00\x44\x00\x77\x00\x78\x00\x14\x00\x15\x00\x03\x00\x04\x00\x68\x00\x20\x00\x6a\x00\x1f\x00\x6c\x00\x49\x00\x27\x00\x69\x00\x24\x00\x28\x00\x04\x00\x77\x00\x78\x00\x75\x00\x76\x00\x77\x00\x78\x00\x16\x00\x6a\x00\x1f\x00\x76\x00\x42\x00\x78\x00\x23\x00\x80\x00\x81\x00\x04\x00\x4c\x00\x16\x00\x75\x00\x76\x00\x40\x00\x51\x00\x52\x00\x53\x00\x85\x00\x55\x00\x56\x00\x16\x00\x21\x00\x22\x00\x23\x00\x84\x00\x25\x00\x26\x00\x27\x00\x2f\x00\x1f\x00\x31\x00\x6a\x00\x04\x00\x6c\x00\x69\x00\x82\x00\x6b\x00\x68\x00\x76\x00\x6a\x00\x78\x00\x6c\x00\x75\x00\x76\x00\x77\x00\x78\x00\x6a\x00\x76\x00\x6c\x00\x78\x00\x75\x00\x76\x00\x77\x00\x78\x00\x26\x00\x6a\x00\x28\x00\x75\x00\x76\x00\x77\x00\x78\x00\x80\x00\x81\x00\x69\x00\x4c\x00\x6b\x00\x75\x00\x76\x00\x16\x00\x51\x00\x52\x00\x53\x00\x04\x00\x55\x00\x56\x00\x16\x00\x76\x00\x1f\x00\x78\x00\x38\x00\x39\x00\x19\x00\x29\x00\x1b\x00\x1f\x00\x38\x00\x39\x00\x2e\x00\x2f\x00\x16\x00\x31\x00\x32\x00\x68\x00\x34\x00\x6a\x00\x18\x00\x6c\x00\x45\x00\x1f\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x4b\x00\x4c\x00\x75\x00\x76\x00\x77\x00\x78\x00\x51\x00\x52\x00\x53\x00\x67\x00\x55\x00\x56\x00\x6a\x00\x80\x00\x81\x00\x89\x00\x2c\x00\x2d\x00\x77\x00\x78\x00\x29\x00\x77\x00\x78\x00\x75\x00\x76\x00\x2e\x00\x2f\x00\x43\x00\x31\x00\x68\x00\x76\x00\x6a\x00\x35\x00\x6c\x00\x45\x00\x88\x00\x2e\x00\x2f\x00\x88\x00\x31\x00\x4b\x00\x4c\x00\x75\x00\x76\x00\x77\x00\x78\x00\x51\x00\x52\x00\x53\x00\x81\x00\x55\x00\x56\x00\x0d\x00\x80\x00\x81\x00\x81\x00\x76\x00\x77\x00\x78\x00\x16\x00\x1f\x00\x16\x00\x01\x00\x16\x00\x23\x00\x1a\x00\x1b\x00\x42\x00\x1f\x00\x68\x00\x29\x00\x6a\x00\x1f\x00\x6c\x00\x23\x00\x89\x00\x25\x00\x26\x00\x27\x00\x77\x00\x78\x00\x42\x00\x75\x00\x76\x00\x77\x00\x78\x00\x10\x00\x11\x00\x2c\x00\x2d\x00\x16\x00\x77\x00\x78\x00\x80\x00\x81\x00\x1b\x00\x88\x00\x76\x00\x77\x00\x78\x00\x1b\x00\x28\x00\x16\x00\x23\x00\x1f\x00\x25\x00\x26\x00\x27\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x3a\x00\x34\x00\x35\x00\x4c\x00\x89\x00\x38\x00\x42\x00\x16\x00\x51\x00\x52\x00\x53\x00\x3e\x00\x55\x00\x56\x00\x1f\x00\x89\x00\x16\x00\x22\x00\x03\x00\x04\x00\x23\x00\x26\x00\x25\x00\x26\x00\x27\x00\x1f\x00\x4d\x00\x18\x00\x4f\x00\x50\x00\x51\x00\x68\x00\x4c\x00\x6a\x00\x1f\x00\x6c\x00\x18\x00\x51\x00\x52\x00\x53\x00\x20\x00\x55\x00\x56\x00\x1f\x00\x75\x00\x76\x00\x77\x00\x78\x00\x2f\x00\x62\x00\x31\x00\x77\x00\x78\x00\x19\x00\x1a\x00\x80\x00\x81\x00\x47\x00\x48\x00\x49\x00\x68\x00\x4c\x00\x6a\x00\x82\x00\x6c\x00\x20\x00\x51\x00\x52\x00\x53\x00\x1f\x00\x55\x00\x56\x00\x29\x00\x75\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x81\x00\x31\x00\x00\x00\x66\x00\x67\x00\x80\x00\x81\x00\x6a\x00\x18\x00\x24\x00\x68\x00\x26\x00\x6a\x00\x49\x00\x6c\x00\x1f\x00\x0e\x00\x41\x00\x75\x00\x76\x00\x42\x00\x43\x00\x44\x00\x75\x00\x76\x00\x77\x00\x78\x00\x19\x00\x03\x00\x04\x00\x1c\x00\x29\x00\x4f\x00\x50\x00\x80\x00\x81\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x76\x00\x77\x00\x78\x00\x35\x00\x29\x00\x75\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x60\x00\x61\x00\x62\x00\x35\x00\x29\x00\x24\x00\x89\x00\x26\x00\x27\x00\x2e\x00\x2f\x00\x44\x00\x31\x00\x32\x00\x19\x00\x1a\x00\x0f\x00\x76\x00\x77\x00\x78\x00\x29\x00\x4d\x00\x4e\x00\x4f\x00\x57\x00\x2e\x00\x2f\x00\x81\x00\x31\x00\x32\x00\x19\x00\x1a\x00\x76\x00\x29\x00\x03\x00\x04\x00\x89\x00\x57\x00\x2e\x00\x2f\x00\x29\x00\x31\x00\x32\x00\x19\x00\x1a\x00\x2e\x00\x2f\x00\x49\x00\x31\x00\x32\x00\x75\x00\x76\x00\x77\x00\x78\x00\x76\x00\x76\x00\x77\x00\x78\x00\x4a\x00\x7a\x00\x84\x00\x2e\x00\x2f\x00\x42\x00\x31\x00\x46\x00\x81\x00\x29\x00\x76\x00\x77\x00\x78\x00\x81\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x32\x00\x3e\x00\x78\x00\x81\x00\x29\x00\x76\x00\x77\x00\x78\x00\x04\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x32\x00\x03\x00\x04\x00\x19\x00\x1a\x00\x19\x00\x1a\x00\x29\x00\x76\x00\x77\x00\x78\x00\x89\x00\x2e\x00\x2f\x00\x04\x00\x31\x00\x32\x00\x04\x00\x19\x00\x1a\x00\x84\x00\x76\x00\x77\x00\x78\x00\x03\x00\x04\x00\x07\x00\x89\x00\x76\x00\x77\x00\x78\x00\x19\x00\x1a\x00\x29\x00\x4f\x00\x2f\x00\x7d\x00\x31\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x32\x00\x29\x00\x76\x00\x77\x00\x78\x00\x89\x00\x2e\x00\x2f\x00\x04\x00\x31\x00\x32\x00\x29\x00\x04\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x04\x00\x31\x00\x32\x00\x89\x00\x19\x00\x1a\x00\x37\x00\x29\x00\x76\x00\x77\x00\x78\x00\x17\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x32\x00\x81\x00\x81\x00\x0e\x00\x81\x00\x81\x00\x81\x00\x29\x00\x76\x00\x77\x00\x78\x00\x89\x00\x2e\x00\x2f\x00\x29\x00\x31\x00\x82\x00\x49\x00\x29\x00\x2e\x00\x2f\x00\x81\x00\x31\x00\x2e\x00\x2f\x00\x81\x00\x31\x00\x89\x00\x81\x00\x81\x00\x76\x00\x77\x00\x78\x00\x18\x00\x76\x00\x77\x00\x78\x00\x81\x00\x81\x00\x04\x00\x04\x00\x82\x00\x29\x00\x18\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x04\x00\x29\x00\x89\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x82\x00\x31\x00\x81\x00\x81\x00\x89\x00\x04\x00\x16\x00\x29\x00\x81\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x29\x00\x81\x00\x81\x00\x84\x00\x16\x00\x2e\x00\x2f\x00\x03\x00\x31\x00\x76\x00\x77\x00\x78\x00\x89\x00\x23\x00\x16\x00\x16\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x76\x00\x77\x00\x78\x00\x16\x00\x29\x00\x16\x00\x15\x00\x1f\x00\x89\x00\x2e\x00\x2f\x00\x33\x00\x31\x00\x1a\x00\x2f\x00\x89\x00\x31\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x1a\x00\x4c\x00\x15\x00\x76\x00\x77\x00\x78\x00\x1b\x00\x3d\x00\x33\x00\x3b\x00\x3c\x00\x29\x00\x3e\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x29\x00\x31\x00\x28\x00\x16\x00\x89\x00\x2e\x00\x2f\x00\x24\x00\x31\x00\x76\x00\x77\x00\x78\x00\x2e\x00\x2f\x00\x89\x00\x31\x00\x19\x00\x33\x00\x76\x00\x77\x00\x78\x00\x2f\x00\x23\x00\x31\x00\x24\x00\x16\x00\x3b\x00\x2f\x00\x89\x00\x31\x00\x23\x00\x3b\x00\x16\x00\x2f\x00\x21\x00\x31\x00\x2f\x00\x89\x00\x31\x00\x6b\x00\x21\x00\x14\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x76\x00\x77\x00\x78\x00\x16\x00\x76\x00\x77\x00\x78\x00\x26\x00\x24\x00\x4c\x00\x2f\x00\x1b\x00\x31\x00\x3d\x00\x2f\x00\x89\x00\x31\x00\x01\x00\x2f\x00\x89\x00\x31\x00\x16\x00\x16\x00\x89\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x24\x00\x4f\x00\x4c\x00\x76\x00\x77\x00\x78\x00\x28\x00\x34\x00\x23\x00\x15\x00\x76\x00\x77\x00\x78\x00\x23\x00\x16\x00\x89\x00\x24\x00\x16\x00\x76\x00\x77\x00\x78\x00\x1e\x00\x89\x00\x26\x00\x76\x00\x77\x00\x78\x00\x33\x00\x33\x00\x89\x00\x76\x00\x77\x00\x78\x00\x76\x00\x77\x00\x78\x00\x4c\x00\x89\x00\x03\x00\x33\x00\x34\x00\x35\x00\x0e\x00\x89\x00\x38\x00\x19\x00\x23\x00\x19\x00\x15\x00\x89\x00\x3e\x00\x24\x00\x89\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x76\x00\x77\x00\x78\x00\x4c\x00\x76\x00\x77\x00\x78\x00\x26\x00\x4d\x00\x19\x00\x4f\x00\x50\x00\x51\x00\x19\x00\x19\x00\x89\x00\x79\x00\x7a\x00\x7b\x00\x89\x00\x7d\x00\x22\x00\x7f\x00\x89\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1f\x00\x23\x00\x09\x00\x4c\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x14\x00\x11\x00\x12\x00\x13\x00\x23\x00\x15\x00\x40\x00\x17\x00\x38\x00\x45\x00\x4d\x00\x19\x00\x6e\x00\x1d\x00\x19\x00\x71\x00\x20\x00\x73\x00\x1b\x00\x15\x00\x03\x00\x25\x00\x19\x00\x79\x00\x7a\x00\x7b\x00\x2a\x00\x7d\x00\x2c\x00\x7f\x00\x1f\x00\x81\x00\x1b\x00\x4a\x00\x19\x00\x41\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1b\x00\x3c\x00\x19\x00\x3e\x00\x3f\x00\x40\x00\x1a\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x21\x00\x48\x00\x1a\x00\x21\x00\x4b\x00\x24\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\x21\x00\x27\x00\x1a\x00\x16\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x16\x00\x11\x00\x12\x00\x13\x00\x16\x00\x15\x00\x1f\x00\x17\x00\x16\x00\x16\x00\x16\x00\x16\x00\x6e\x00\x1d\x00\x16\x00\x71\x00\x20\x00\x73\x00\x49\x00\x1a\x00\x1e\x00\x25\x00\x19\x00\x79\x00\x7a\x00\x7b\x00\x2a\x00\x7d\x00\x2c\x00\x7f\x00\x52\x00\x81\x00\x41\x00\x20\x00\x52\x00\x29\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1a\x00\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x48\x00\xff\xff\xff\xff\x4b\x00\xff\xff\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\x1f\x00\xff\xff\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\x6e\x00\x3e\x00\x3f\x00\x71\x00\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\x4d\x00\x7f\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x12\x00\x6e\x00\xff\xff\x15\x00\x71\x00\x17\x00\x73\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x25\x00\x81\x00\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x15\x00\x45\x00\x46\x00\xff\xff\x48\x00\xff\xff\xff\xff\x4b\x00\xff\xff\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\x19\x00\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\x42\x00\x43\x00\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\x03\x00\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\x42\x00\x43\x00\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\x19\x00\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\x03\x00\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\x6e\x00\x3e\x00\x3f\x00\x71\x00\xff\xff\x73\x00\xff\xff\x15\x00\x16\x00\x46\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\x4b\x00\x7d\x00\x4d\x00\x7f\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\x6e\x00\x3e\x00\x3f\x00\x71\x00\xff\xff\x73\x00\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\x4b\x00\x7d\x00\x4d\x00\x7f\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x46\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x15\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\x34\x00\x35\x00\xff\xff\x2a\x00\x38\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x01\x00\x3e\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\x0e\x00\x3e\x00\x3f\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\x18\x00\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\x03\x00\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x4d\x00\x2c\x00\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x25\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\x80\x00\x81\x00\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\x15\x00\x71\x00\x17\x00\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x25\x00\x81\x00\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x15\x00\x38\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x1d\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x2a\x00\x4d\x00\x05\x00\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\x21\x00\xff\xff\x15\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x3e\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\x15\x00\x4f\x00\x50\x00\x51\x00\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x28\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\xff\xff\x15\x00\xff\xff\x17\x00\x3e\x00\xff\xff\xff\xff\xff\xff\x47\x00\x1d\x00\xff\xff\xff\xff\xff\xff\x21\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x2d\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\x1f\x00\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x28\x00\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x28\x00\xff\xff\xff\xff\x2b\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\xff\xff\x15\x00\xff\xff\x17\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\x2d\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x2d\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x3e\x00\x17\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x1d\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1d\x00\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x2b\x00\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x2d\x00\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\xff\xff\xff\xff\x15\x00\x16\x00\x3e\x00\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x4d\x00\x22\x00\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\x15\x00\x16\x00\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x28\x00\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\x15\x00\xff\xff\x17\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x47\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x18\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x3e\x00\x15\x00\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\xff\xff\xff\xff\xff\xff\x15\x00\x3e\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\x15\x00\xff\xff\x17\x00\xff\xff\x3e\x00\x15\x00\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\xff\xff\xff\xff\xff\xff\x15\x00\x3e\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x34\x00\x35\x00\xff\xff\xff\xff\x38\x00\x3e\x00\x15\x00\xff\xff\x17\x00\x53\x00\x3e\x00\x55\x00\x56\x00\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x4d\x00\x03\x00\x4f\x00\x50\x00\x51\x00\x4d\x00\x01\x00\x4f\x00\x50\x00\x51\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x34\x00\x35\x00\x15\x00\x16\x00\x38\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\xff\xff\x05\x00\x38\x00\x07\x00\xff\xff\x34\x00\x35\x00\x4c\x00\x3e\x00\x38\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\x3e\x00\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\x4d\x00\x05\x00\x4f\x00\x50\x00\x51\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x6f\x00\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x75\x00\x76\x00\x77\x00\x78\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\x58\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x05\x00\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x80\x00\x81\x00\x05\x00\x06\x00\x07\x00\x08\x00\x75\x00\x76\x00\x77\x00\x78\x00\x21\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\x80\x00\x81\x00\x16\x00\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\x21\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x54\x00\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\x55\x00\x56\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x35\x00\x33\x00\x34\x00\xa8\x01\x35\x00\x35\x00\xcb\x00\x31\x00\x99\x01\x7e\x01\x37\x01\x38\x01\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x38\x02\xf9\x00\x46\x01\x47\x01\xf8\x01\x46\x01\x49\x01\x39\x02\x57\x01\x60\x00\x4e\x02\x87\x01\x29\x02\x38\x00\x17\x00\x18\x00\xd5\x01\x3a\x02\x57\x01\xcf\x00\xe6\x00\x66\x02\x39\x00\x3a\x00\x15\x02\xc7\x01\xd9\x01\x2e\x02\xa5\x00\x3b\x00\x08\x02\x74\x02\x8a\x01\xf6\x01\x2b\x01\xca\x01\x5d\x02\x39\x00\x3a\x00\x2a\x01\x2b\x01\xb5\x01\x56\x01\x57\x01\x59\x01\x57\x01\x2b\x01\xd0\x00\x17\x00\x18\x00\x92\x01\xb0\x01\x2b\x01\xf4\x00\xf5\x00\xba\x00\x8b\x01\x8c\x01\x8d\x01\x8e\x01\x8f\x01\x90\x01\x00\x01\x6d\x01\xbb\x00\xbc\x00\xe4\x01\xfa\x00\x3b\x00\x33\x01\xf5\x01\x09\x02\xe6\x01\x93\x01\xa8\x00\x58\x01\x57\x02\x45\x02\xbd\x00\xbe\x00\x55\x02\xfb\x00\x6e\x01\x3b\x00\x07\x01\x88\x01\x11\x00\xbf\x00\x39\x01\xac\x00\xad\x00\xae\x00\x11\x02\x41\x00\x58\x01\x59\x02\x44\x02\x45\x02\xb5\x01\x0e\x00\x0f\x00\x3a\x01\x11\x00\x48\x01\x58\x01\x9e\x01\x48\x01\x3c\x00\x5b\x02\x33\x02\xdd\x01\x36\x00\x36\x00\x93\x01\x9a\x01\x32\x00\x32\x00\x3b\x01\xa2\x01\x3c\x00\x3c\x00\xe7\x00\x08\x01\x3c\x00\x3c\x00\x42\x00\xec\x01\x48\x01\xaf\x00\x58\x01\xcc\x00\x58\x01\x39\x01\xc0\x00\x06\x00\x07\x00\x34\x01\x08\x00\x09\x00\xbb\x00\xbc\x00\x6e\x01\xe6\x01\x0e\x00\x0f\x00\x3a\x01\x11\x00\x0e\x00\x0f\x00\xa8\x00\xfc\x01\x87\x01\x75\x02\xbd\x00\xbe\x00\x59\x00\x0b\x00\x5b\x00\xb1\x00\x76\x00\x0d\x00\x3b\x01\xbf\x00\x46\x02\xac\x00\xad\x00\xae\x00\x0a\x02\x87\x01\x0e\x00\x0f\x00\x10\x00\x11\x00\x6e\x01\x9f\x01\xeb\x00\x2b\x01\xa0\x01\x47\x02\x1b\x02\x12\x00\xc1\x00\x70\x02\x46\x02\xcc\x01\xcd\x01\xa7\x00\xa2\x01\x6e\x00\x9f\x01\xa3\x01\x48\x02\xa0\x01\x84\x02\xa1\x01\x2a\x02\x2b\x01\x85\x02\x47\x02\x8c\x02\x2c\x02\x43\x01\xa2\x01\xaf\x00\xa8\x00\xa3\x01\x71\x02\x72\x02\xc0\x00\x06\x00\x07\x00\x48\x02\x08\x00\x09\x00\x2b\x01\xa9\x00\xaa\x00\xab\x00\x64\x02\xac\x00\xad\x00\xae\x00\xec\x00\xed\x00\xee\x00\x88\x01\x11\x00\x77\x02\x78\x02\x17\x00\x18\x00\x0b\x00\x6e\x00\xb1\x00\x7a\x01\x0d\x00\x34\x02\x70\x02\x46\x02\x7b\x01\x0c\x01\xa7\x00\x88\x01\x11\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x14\x02\x34\x01\x00\x01\x2b\x01\x35\x02\x47\x02\x86\x02\x12\x00\xc1\x00\x4c\x02\xaf\x00\xa8\x00\x0e\x00\x0f\x00\x8b\x02\xb0\x00\x06\x00\x07\x00\x48\x02\x08\x00\x09\x00\x81\x02\xb5\x00\xaa\x00\xab\x00\x04\x02\xac\x00\xad\x00\xae\x00\x8d\x02\x82\x02\xd4\x00\xce\x01\xff\x01\xcf\x01\x79\x02\x4a\x02\x7a\x02\x0b\x00\xd4\x01\xb1\x00\xd5\x01\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xce\x01\x2b\x01\xcf\x01\x7b\x02\x0e\x00\x0f\x00\x10\x00\x11\x00\xc1\x01\x34\x01\xc2\x01\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xb2\x00\x79\x02\xaf\x00\x7a\x02\x0e\x00\x0f\x00\x37\x02\xb0\x00\x06\x00\x07\x00\xff\x01\x08\x00\x09\x00\x22\x02\x2b\x01\x38\x02\x7b\x02\x14\x02\xe5\x01\x39\x00\xd1\x00\x9d\x01\x23\x02\xe4\x01\xe5\x01\xd2\x00\xd3\x00\x76\x01\xd4\x00\x97\x01\x0b\x00\x98\x01\xb1\x00\x7c\x01\x0d\x00\x00\x02\x92\x00\xd6\x00\xd7\x00\x11\x00\x78\x01\x01\x02\x02\x02\x0e\x00\x0f\x00\x10\x00\x11\x00\xb0\x00\x06\x00\x07\x00\x1d\x01\x08\x00\x09\x00\x87\x00\x12\x00\xb2\x00\xd8\x00\xe7\x01\x87\x01\xe1\x01\x11\x00\x5c\x01\xe1\x01\x11\x00\x0e\x00\x0f\x00\x52\x01\xd3\x00\x11\x02\xd4\x00\x0b\x00\x6e\x01\x0c\x00\x5d\x01\x0d\x00\x00\x02\x63\x02\x6b\x02\xd3\x00\xe2\x01\xd4\x00\x03\x02\x02\x02\x0e\x00\x0f\x00\x10\x00\x11\x00\xb0\x00\x06\x00\x07\x00\xe6\x01\x08\x00\x09\x00\x3f\x01\x12\x00\x13\x00\xe6\x01\xd6\x00\xd7\x00\x11\x00\x77\x01\x96\xff\xa8\x00\x15\x00\x8f\x00\x96\xff\x40\x01\xbe\x00\xfb\x01\x78\x01\x0b\x00\x6f\x00\x0c\x00\x90\x00\x0d\x00\xbf\x00\xd8\x00\xac\x00\xad\x00\xae\x00\xe1\x01\x11\x00\x09\x02\x0e\x00\x0f\x00\x10\x00\x11\x00\x05\x02\x06\x02\x86\x01\x87\x01\xa8\x00\x88\x01\x11\x00\x12\x00\x13\x00\x41\x01\x12\x02\xd6\x00\xd7\x00\x11\x00\x18\x01\x17\x02\x91\x00\xbf\x00\x19\x01\xac\x00\xad\x00\xae\x00\xd6\x00\xd7\x00\x11\x00\x92\x00\x0c\x02\x26\x00\x27\x00\xaf\x00\xd8\x00\x29\x00\x0f\x02\xa8\x00\xc0\x00\x06\x00\x07\x00\x2b\x00\x08\x00\x09\x00\x9a\x00\xd8\x00\x94\x00\x9b\x00\x17\x00\x18\x00\x29\x01\x9c\x00\xac\x00\xad\x00\xae\x00\x95\x00\x2e\x00\x7d\x01\x2f\x00\x30\x00\x31\x00\x0b\x00\xaf\x00\xb1\x00\x7a\x01\x0d\x00\x96\x00\xc0\x00\x06\x00\x07\x00\x19\x02\x08\x00\x09\x00\x90\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x67\x01\x27\x02\xd4\x00\x88\x01\x11\x00\x39\x00\x3e\x00\x12\x00\xc1\x00\xdb\x01\xdc\x01\xdd\x01\x0b\x00\xaf\x00\xb1\x00\xc4\x01\x0d\x00\x6e\x00\xb0\x00\x06\x00\x07\x00\xd7\x01\x08\x00\x09\x00\x88\x02\x0e\x00\x0f\x00\x10\x00\x11\x00\x52\x01\xd3\x00\xc8\x01\xd4\x00\xcf\x00\x85\x00\x86\x00\x12\x00\xc1\x00\x87\x00\x97\x00\x32\x01\x0b\x00\x33\x01\xb1\x00\xda\x01\x0d\x00\x95\x00\xf2\xff\x89\x02\x0e\x00\x0f\x00\xec\x00\xed\x00\xee\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x39\x00\xb9\x00\xba\x00\xd0\x00\x5f\x01\x0e\x02\x0f\x02\x12\x00\xb2\x00\x52\x01\xd3\x00\x60\x01\xd4\x00\xd6\x00\xd7\x00\x11\x00\x61\x01\x5f\x01\x81\x00\x0f\x00\x82\x00\x11\x00\x52\x01\xd3\x00\x60\x01\xd4\x00\xbd\x01\xbe\x01\xbf\x01\x61\x01\xd1\x00\x32\x01\xd8\x00\x33\x01\x43\x01\xd2\x00\xd3\x00\xde\x01\xd4\x00\x50\x02\x39\x00\x3e\x00\xea\x01\xd6\x00\xd7\x00\x11\x00\xd1\x00\x2e\x01\x2f\x01\x30\x01\x62\x01\xd2\x00\xd3\x00\xe9\x01\xd4\x00\xfa\x01\x39\x00\xee\x01\xef\x01\xd1\x00\xb9\x00\xba\x00\xd8\x00\x62\x01\xd2\x00\xd3\x00\xd1\x00\xd4\x00\xee\x01\x39\x00\x3a\x00\xd2\x00\xd3\x00\x6c\x01\xd4\x00\xf0\x01\x8a\x00\x0f\x00\x82\x00\x11\x00\x80\x01\xd6\x00\xd7\x00\x11\x00\x83\x01\x59\x02\x85\x01\x6e\x02\xd3\x00\x90\x01\xd4\x00\x94\x01\x63\x01\xd1\x00\xd6\x00\xd7\x00\x11\x00\x93\x01\xd2\x00\xd3\x00\xd8\x00\xd4\x00\xb4\x01\x6f\x02\x96\x01\x63\x01\xd1\x00\xd6\x00\xd7\x00\x11\x00\x99\x01\xd2\x00\xd3\x00\xd8\x00\xd4\x00\x4d\x01\xb9\x00\xba\x00\x39\x00\xe9\x00\x39\x00\x0a\x01\xd1\x00\xd6\x00\xd7\x00\x11\x00\xd8\x00\xd2\x00\xd3\x00\x9d\x01\xd4\x00\x4e\x01\xa7\x01\x39\x00\x3e\x00\xa9\x01\xd6\x00\xd7\x00\x11\x00\xb9\x00\xba\x00\xab\x01\xd8\x00\xd6\x00\xd7\x00\x11\x00\x39\x00\x3e\x00\xd1\x00\xb2\x01\x6c\x02\xb5\x01\xd4\x00\xd2\x00\xd3\x00\xd8\x00\xd4\x00\x55\x01\xd1\x00\xd6\x00\xd7\x00\x11\x00\xd8\x00\xd2\x00\xd3\x00\xb6\x01\xd4\x00\xd5\x00\xd1\x00\xb7\x01\xd6\x00\xd7\x00\x11\x00\xd2\x00\xd3\x00\xb9\x01\xd4\x00\xe1\x00\xd8\x00\x39\x00\x44\x00\x35\x01\xd1\x00\xd6\x00\xd7\x00\x11\x00\x44\x01\xd2\x00\xd3\x00\xd8\x00\xd4\x00\x1c\x01\x36\x01\x4b\x01\x53\x01\x4c\x01\x4f\x01\x66\x01\x86\x02\xd6\x00\xd7\x00\x11\x00\xd8\x00\x52\x01\xd3\x00\xc9\x01\xd4\x00\xcd\x00\x6a\x01\xd3\x01\x52\x01\xd3\x00\xd0\x00\xd4\x00\x52\x01\xd3\x00\xde\x00\xd4\x00\xd8\x00\xdf\x00\xe0\x00\xd6\x00\xd7\x00\x11\x00\xe9\x00\xd6\x00\xd7\x00\x11\x00\xe3\x00\xfc\x00\xef\x00\xf1\x00\xf8\x00\xf1\x01\xe9\x00\xd6\x00\xd7\x00\x11\x00\x52\x01\xd3\x00\xd8\x00\xd4\x00\x00\x01\xf2\x01\xd8\x00\xd6\x00\xd7\x00\x11\x00\x52\x01\xd3\x00\x04\x01\xd4\x00\xfe\x00\x0a\x01\xd8\x00\xa6\x00\x88\x02\xf3\x01\x80\x00\xd6\x00\xd7\x00\x11\x00\x52\x01\xd3\x00\xd8\x00\xd4\x00\x70\x01\x46\x00\x03\x00\xb7\x00\x80\x02\x52\x01\xd3\x00\x17\x00\xd4\x00\xd6\x00\xd7\x00\x11\x00\xd8\x00\x6b\x02\x83\x02\x74\x02\xd6\x00\xd7\x00\x11\x00\x57\x02\xd6\x00\xd7\x00\x11\x00\x77\x02\x71\x01\x53\x02\x55\x02\x57\x02\xd8\x00\x52\x01\xd3\x00\x62\x02\xd4\x00\xe4\xfe\x5d\x02\xd8\x00\xd4\x00\x3b\x02\xd3\x00\xd8\x00\xd4\x00\x5b\x02\xe0\x01\x44\x02\xd6\x00\xd7\x00\x11\x00\x4c\x02\x5e\x02\x63\x02\x3c\x02\x3d\x02\x51\x01\x3e\x02\xd6\x00\xd7\x00\x11\x00\x52\x01\xd3\x00\x5a\x01\xd4\x00\x69\x02\x8d\x00\xd8\x00\x52\x01\xd3\x00\x2e\x02\xd4\x00\xd6\x00\xd7\x00\x11\x00\x31\x02\xd3\x00\xd8\x00\xd4\x00\x4e\x02\x32\x02\xd6\x00\xd7\x00\x11\x00\x6d\x02\xfa\x01\xd4\x00\x50\x02\xfe\x01\x93\x01\x58\x02\xd8\x00\xd4\x00\xff\x01\x93\x01\x0c\x02\x67\x01\x1d\x02\xd4\x00\x74\x01\xd8\x00\xd4\x00\x3f\x02\x1e\x02\x1f\x02\xd6\x00\xd7\x00\x11\x00\x18\x02\xd6\x00\xd7\x00\x11\x00\x20\x02\xd6\x00\xd7\x00\x40\x02\xc1\x01\x24\x02\x29\x02\x67\x01\xc3\x01\xd4\x00\xc6\x01\xae\x01\xd8\x00\xd4\x00\x15\x00\x67\x01\xd8\x00\xd4\x00\xc7\x01\xcc\x01\xd8\x00\xd6\x00\xd7\x00\x11\x00\xd7\x01\xe1\x01\xd9\x01\xe0\x01\xd6\x00\xd7\x00\x11\x00\xe9\x01\xec\x01\xf5\x01\x30\x02\xd6\x00\xd7\x00\x11\x00\xf8\x01\x74\x01\xd8\x00\x73\x01\x79\x01\xd6\x00\xd7\x00\x11\x00\x7e\x01\xd8\x00\x96\x01\xd6\x00\xd7\x00\x11\x00\x80\x01\x83\x01\xd8\x00\xd6\x00\xd7\x00\x11\x00\xd6\x00\xd7\x00\x11\x00\x85\x01\xd8\x00\x17\x00\x31\x02\x26\x00\x27\x00\x9c\x01\xd8\x00\x29\x00\x39\x00\xa6\x01\xf1\x00\xab\x01\xd8\x00\x2b\x00\xae\x01\xd8\x00\xd6\x00\xd7\x00\x11\x00\xad\x01\xd6\x00\xd7\x00\x11\x00\xb4\x01\xd6\x00\xd7\x00\x11\x00\x33\x01\x2e\x00\x39\x00\x2f\x00\x30\x00\x31\x00\x02\xff\xb9\x01\xd8\x00\x20\x02\x58\x00\x59\x00\xd8\x00\x5b\x00\x20\x01\x76\x00\xd8\x00\x15\x00\x16\x00\x17\x00\x18\x00\x21\x01\x2e\x01\x46\x01\x3f\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x4b\x01\xb4\x00\xc3\x00\xa5\xfe\x51\x01\x20\x00\x6c\x01\x21\x00\xe5\x00\xe6\x00\x55\x01\xf1\x00\x71\x00\x22\x00\xf3\x00\x72\x00\xa5\xfe\x73\x00\xf4\x00\xf7\x00\x17\x00\x23\x00\x02\x01\x74\x00\x58\x00\x75\x00\x24\x00\x5b\x00\x25\x00\x76\x00\x00\x01\xba\x01\x03\x01\x04\x01\x06\x01\xb7\x00\x26\x00\xc4\x00\x28\x00\xc5\x00\x29\x00\xc6\x00\xc7\x00\x07\x01\x2a\x00\x02\xff\x2b\x00\x2c\x00\xc8\x00\x70\x00\xa5\xfe\xa5\xfe\xa5\xfe\xc9\x00\x41\x00\x16\x01\xca\x00\x70\x00\x1b\x01\xb5\x00\x17\x01\x2e\x00\xcb\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x1c\x01\x84\x00\x70\x00\xb3\xfe\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xb4\xfe\xb4\x00\xc3\x00\xa5\xfe\xb5\xfe\x20\x00\x98\x00\x21\x00\xb9\xfe\xbb\xfe\xbe\xfe\x8c\x00\x71\x00\x22\x00\x8d\x00\x72\x00\xa5\xfe\x73\x00\xa0\x00\x70\x00\x99\x00\x23\x00\x39\x00\x74\x00\x58\x00\x75\x00\x24\x00\x5b\x00\x25\x00\x76\x00\xff\xff\xee\x00\xb7\x00\x6e\x00\xff\xff\x6f\x00\x26\x00\xc4\x00\x28\x00\xc5\x00\x29\x00\xc6\x00\xc7\x00\x70\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\xa5\xfe\xa5\xfe\xa5\xfe\xc9\x00\x41\x00\x00\x00\xca\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x2e\x00\xcb\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x63\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x64\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x71\x00\x2b\x00\x2c\x00\x72\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x74\x00\x58\x00\x75\x00\x00\x00\x5b\x00\x2e\x00\x76\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\xb4\x00\xc3\x00\x71\x00\x00\x00\x20\x00\x72\x00\x21\x00\x73\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x22\x00\x74\x00\x58\x00\x75\x00\x00\x00\x5b\x00\x00\x00\x76\x00\x23\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x26\x00\xc4\x00\x28\x00\xc5\x00\x29\x00\xc6\x00\xc7\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\xc8\x00\x00\x00\x00\x00\x00\x00\xd1\x01\xc9\x00\x41\x00\x00\x00\xca\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x2e\x00\xcb\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\xb4\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x39\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\xa5\xfe\xa5\xfe\xa5\xfe\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\xb4\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x17\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\xa5\xfe\xa5\xfe\xa5\xfe\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x39\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x17\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x71\x00\x2b\x00\x2c\x00\x72\x00\x00\x00\x92\x00\x00\x00\x2d\x01\x4a\x02\x41\x00\x00\x00\x74\x00\x58\x00\x75\x00\xb5\x00\x5b\x00\x2e\x00\x76\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x71\x00\x2b\x00\x2c\x00\x72\x00\x00\x00\x73\x00\x00\x00\x89\x00\x00\x00\x41\x00\x00\x00\x74\x00\x58\x00\x75\x00\xb5\x00\x5b\x00\x2e\x00\x76\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x41\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x7d\x02\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x13\x01\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x26\x00\x27\x00\x00\x00\x24\x00\x29\x00\x25\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x70\x01\x2b\x00\x2c\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x50\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x17\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x01\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x01\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x01\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x01\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\xa5\xfe\xa5\xfe\x00\x00\x20\x00\xa5\xfe\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\xfe\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\xa5\xfe\x25\x00\xa5\xfe\xa5\xfe\xa5\xfe\x15\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x25\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x23\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x25\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x12\x00\x13\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x20\x00\x72\x00\x21\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x74\x00\x58\x00\x75\x00\x00\x00\x5b\x00\x00\x00\x76\x00\x23\x00\x77\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x24\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x20\x00\x29\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x22\x00\x79\x00\x60\x00\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x24\x00\x2e\x00\x79\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x7a\x00\x00\x00\x2d\x01\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x2b\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x89\x00\x2f\x00\x30\x00\x31\x00\x00\x00\xda\x00\x65\x01\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x66\x01\x17\x00\x18\x00\x00\x00\x57\xff\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\x00\x00\xda\x00\x00\x00\xdb\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x3e\x01\xdc\x00\x00\x00\x00\x00\x00\x00\x57\xff\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x15\x00\x61\x02\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\xda\x00\x65\x01\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x64\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x66\x01\x00\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x00\x00\xda\x00\x00\x00\xdb\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x69\x01\x00\x00\x00\x00\x6a\x01\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x8b\x02\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\x00\x00\xda\x00\x00\x00\xdb\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x15\x00\x43\x02\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x60\x02\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x2b\x00\xdb\x00\x00\x00\x00\x00\x42\x02\x00\x00\xdb\x00\xdc\x00\x79\x00\x60\x00\x61\x00\x62\x00\xdc\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x66\x02\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x43\x02\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\x00\x00\x00\x00\xd1\x01\xd2\x01\x2b\x00\x00\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x2e\x00\xd3\x01\x2f\x00\x30\x00\x31\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x89\x00\x3d\x01\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x69\x01\x00\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x5c\x01\x00\x00\x00\x00\x00\x00\x3e\x01\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\xda\x00\x00\x00\xdb\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\x00\x00\x00\x00\x00\x00\xda\x00\x2b\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x00\x00\xda\x00\x00\x00\xdb\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\x00\x00\x00\x00\x00\x00\xda\x00\x2b\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x00\x00\xda\x00\x00\x00\xdb\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2b\x00\xda\x00\x00\x00\xdb\x00\x45\x00\x2b\x00\x08\x00\x09\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2e\x00\x17\x00\xdd\x00\xde\x00\x31\x00\x2e\x00\x15\x00\xdd\x00\xde\x00\xe3\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x26\x00\x27\x00\x7d\x02\x7e\x02\x29\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x02\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x02\x2e\x00\x00\x00\xdd\x00\xde\x00\x31\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x79\x00\x29\x00\x61\x00\x00\x00\x26\x00\x27\x00\x53\x02\x2b\x00\x29\x00\x00\x00\x00\x00\xb0\x00\x06\x00\x07\x00\x2b\x00\x08\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x30\x00\x31\x00\x00\x00\x00\x00\x2e\x00\x79\x00\x2f\x00\x30\x00\x31\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x13\x00\x50\x00\x51\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x52\x00\x53\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x54\x00\x00\x00\x55\x00\x00\x00\x00\x00\x56\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x12\x00\x13\x00\xa0\x00\x05\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\xa0\x00\x05\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x13\x00\xa4\x00\xa3\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x04\x00\x05\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0c\x01\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x49\x00\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x05\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\xbb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x26\x01\x05\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x4e\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x04\x00\x05\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x51\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x2b\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x24\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x26\x02\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xb0\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xbc\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x21\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xf7\x00\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0f\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x11\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x19\x01\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x79\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x44\x00\x3f\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x12\x00\x13\x00\x00\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x22\x01\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x23\x01\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x22\x01\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x01\x24\x01\x00\x00\x00\x00\x22\x01\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x8d\x00\x06\x00\x07\x00\x00\x00\x08\x00\x09\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x07\x00\x00\x00\x08\x00\x09\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x79\x00\x60\x00\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x12\x00\x13\x00\x79\x00\x60\x00\x61\x00\x62\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x7a\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\xa5\xfe\x12\x00\x13\x00\x15\x01\x00\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x00\x00\x7a\x00\x79\x00\x60\x00\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x60\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x01\x00\x00\x00\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x7c\x00\x7d\x00\x68\x00\x69\x00\x6a\x00\x7e\x00\x7f\x00\x80\x00\x47\x00\x48\x00\x09\x00\x00\x00\x00\x00\x00\x00\x89\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x9c\x00\x09\x00\x12\x00\x13\x00\x00\x00\x70\x00\x09\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x00\x00\x12\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x12\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = array (2, 356) [-	(2 , happyReduce_2),-	(3 , happyReduce_3),-	(4 , happyReduce_4),-	(5 , happyReduce_5),-	(6 , happyReduce_6),-	(7 , happyReduce_7),-	(8 , happyReduce_8),-	(9 , happyReduce_9),-	(10 , happyReduce_10),-	(11 , happyReduce_11),-	(12 , happyReduce_12),-	(13 , happyReduce_13),-	(14 , happyReduce_14),-	(15 , happyReduce_15),-	(16 , happyReduce_16),-	(17 , happyReduce_17),-	(18 , happyReduce_18),-	(19 , happyReduce_19),-	(20 , happyReduce_20),-	(21 , happyReduce_21),-	(22 , happyReduce_22),-	(23 , happyReduce_23),-	(24 , happyReduce_24),-	(25 , happyReduce_25),-	(26 , happyReduce_26),-	(27 , happyReduce_27),-	(28 , happyReduce_28),-	(29 , happyReduce_29),-	(30 , happyReduce_30),-	(31 , happyReduce_31),-	(32 , happyReduce_32),-	(33 , happyReduce_33),-	(34 , happyReduce_34),-	(35 , happyReduce_35),-	(36 , happyReduce_36),-	(37 , happyReduce_37),-	(38 , happyReduce_38),-	(39 , happyReduce_39),-	(40 , happyReduce_40),-	(41 , happyReduce_41),-	(42 , happyReduce_42),-	(43 , happyReduce_43),-	(44 , happyReduce_44),-	(45 , happyReduce_45),-	(46 , happyReduce_46),-	(47 , happyReduce_47),-	(48 , happyReduce_48),-	(49 , happyReduce_49),-	(50 , happyReduce_50),-	(51 , happyReduce_51),-	(52 , happyReduce_52),-	(53 , happyReduce_53),-	(54 , happyReduce_54),-	(55 , happyReduce_55),-	(56 , happyReduce_56),-	(57 , happyReduce_57),-	(58 , happyReduce_58),-	(59 , happyReduce_59),-	(60 , happyReduce_60),-	(61 , happyReduce_61),-	(62 , happyReduce_62),-	(63 , happyReduce_63),-	(64 , happyReduce_64),-	(65 , happyReduce_65),-	(66 , happyReduce_66),-	(67 , happyReduce_67),-	(68 , happyReduce_68),-	(69 , happyReduce_69),-	(70 , happyReduce_70),-	(71 , happyReduce_71),-	(72 , happyReduce_72),-	(73 , happyReduce_73),-	(74 , happyReduce_74),-	(75 , happyReduce_75),-	(76 , happyReduce_76),-	(77 , happyReduce_77),-	(78 , happyReduce_78),-	(79 , happyReduce_79),-	(80 , happyReduce_80),-	(81 , happyReduce_81),-	(82 , happyReduce_82),-	(83 , happyReduce_83),-	(84 , happyReduce_84),-	(85 , happyReduce_85),-	(86 , happyReduce_86),-	(87 , happyReduce_87),-	(88 , happyReduce_88),-	(89 , happyReduce_89),-	(90 , happyReduce_90),-	(91 , happyReduce_91),-	(92 , happyReduce_92),-	(93 , happyReduce_93),-	(94 , happyReduce_94),-	(95 , happyReduce_95),-	(96 , happyReduce_96),-	(97 , happyReduce_97),-	(98 , happyReduce_98),-	(99 , happyReduce_99),-	(100 , happyReduce_100),-	(101 , happyReduce_101),-	(102 , happyReduce_102),-	(103 , happyReduce_103),-	(104 , happyReduce_104),-	(105 , happyReduce_105),-	(106 , happyReduce_106),-	(107 , happyReduce_107),-	(108 , happyReduce_108),-	(109 , happyReduce_109),-	(110 , happyReduce_110),-	(111 , happyReduce_111),-	(112 , happyReduce_112),-	(113 , happyReduce_113),-	(114 , happyReduce_114),-	(115 , happyReduce_115),-	(116 , happyReduce_116),-	(117 , happyReduce_117),-	(118 , happyReduce_118),-	(119 , happyReduce_119),-	(120 , happyReduce_120),-	(121 , happyReduce_121),-	(122 , happyReduce_122),-	(123 , happyReduce_123),-	(124 , happyReduce_124),-	(125 , happyReduce_125),-	(126 , happyReduce_126),-	(127 , happyReduce_127),-	(128 , happyReduce_128),-	(129 , happyReduce_129),-	(130 , happyReduce_130),-	(131 , happyReduce_131),-	(132 , happyReduce_132),-	(133 , happyReduce_133),-	(134 , happyReduce_134),-	(135 , happyReduce_135),-	(136 , happyReduce_136),-	(137 , happyReduce_137),-	(138 , happyReduce_138),-	(139 , happyReduce_139),-	(140 , happyReduce_140),-	(141 , happyReduce_141),-	(142 , happyReduce_142),-	(143 , happyReduce_143),-	(144 , happyReduce_144),-	(145 , happyReduce_145),-	(146 , happyReduce_146),-	(147 , happyReduce_147),-	(148 , happyReduce_148),-	(149 , happyReduce_149),-	(150 , happyReduce_150),-	(151 , happyReduce_151),-	(152 , happyReduce_152),-	(153 , happyReduce_153),-	(154 , happyReduce_154),-	(155 , happyReduce_155),-	(156 , happyReduce_156),-	(157 , happyReduce_157),-	(158 , happyReduce_158),-	(159 , happyReduce_159),-	(160 , happyReduce_160),-	(161 , happyReduce_161),-	(162 , happyReduce_162),-	(163 , happyReduce_163),-	(164 , happyReduce_164),-	(165 , happyReduce_165),-	(166 , happyReduce_166),-	(167 , happyReduce_167),-	(168 , happyReduce_168),-	(169 , happyReduce_169),-	(170 , happyReduce_170),-	(171 , happyReduce_171),-	(172 , happyReduce_172),-	(173 , happyReduce_173),-	(174 , happyReduce_174),-	(175 , happyReduce_175),-	(176 , happyReduce_176),-	(177 , happyReduce_177),-	(178 , happyReduce_178),-	(179 , happyReduce_179),-	(180 , happyReduce_180),-	(181 , happyReduce_181),-	(182 , happyReduce_182),-	(183 , happyReduce_183),-	(184 , happyReduce_184),-	(185 , happyReduce_185),-	(186 , happyReduce_186),-	(187 , happyReduce_187),-	(188 , happyReduce_188),-	(189 , happyReduce_189),-	(190 , happyReduce_190),-	(191 , happyReduce_191),-	(192 , happyReduce_192),-	(193 , happyReduce_193),-	(194 , happyReduce_194),-	(195 , happyReduce_195),-	(196 , happyReduce_196),-	(197 , happyReduce_197),-	(198 , happyReduce_198),-	(199 , happyReduce_199),-	(200 , happyReduce_200),-	(201 , happyReduce_201),-	(202 , happyReduce_202),-	(203 , happyReduce_203),-	(204 , happyReduce_204),-	(205 , happyReduce_205),-	(206 , happyReduce_206),-	(207 , happyReduce_207),-	(208 , happyReduce_208),-	(209 , happyReduce_209),-	(210 , happyReduce_210),-	(211 , happyReduce_211),-	(212 , happyReduce_212),-	(213 , happyReduce_213),-	(214 , happyReduce_214),-	(215 , happyReduce_215),-	(216 , happyReduce_216),-	(217 , happyReduce_217),-	(218 , happyReduce_218),-	(219 , happyReduce_219),-	(220 , happyReduce_220),-	(221 , happyReduce_221),-	(222 , happyReduce_222),-	(223 , happyReduce_223),-	(224 , happyReduce_224),-	(225 , happyReduce_225),-	(226 , happyReduce_226),-	(227 , happyReduce_227),-	(228 , happyReduce_228),-	(229 , happyReduce_229),-	(230 , happyReduce_230),-	(231 , happyReduce_231),-	(232 , happyReduce_232),-	(233 , happyReduce_233),-	(234 , happyReduce_234),-	(235 , happyReduce_235),-	(236 , happyReduce_236),-	(237 , happyReduce_237),-	(238 , happyReduce_238),-	(239 , happyReduce_239),-	(240 , happyReduce_240),-	(241 , happyReduce_241),-	(242 , happyReduce_242),-	(243 , happyReduce_243),-	(244 , happyReduce_244),-	(245 , happyReduce_245),-	(246 , happyReduce_246),-	(247 , happyReduce_247),-	(248 , happyReduce_248),-	(249 , happyReduce_249),-	(250 , happyReduce_250),-	(251 , happyReduce_251),-	(252 , happyReduce_252),-	(253 , happyReduce_253),-	(254 , happyReduce_254),-	(255 , happyReduce_255),-	(256 , happyReduce_256),-	(257 , happyReduce_257),-	(258 , happyReduce_258),-	(259 , happyReduce_259),-	(260 , happyReduce_260),-	(261 , happyReduce_261),-	(262 , happyReduce_262),-	(263 , happyReduce_263),-	(264 , happyReduce_264),-	(265 , happyReduce_265),-	(266 , happyReduce_266),-	(267 , happyReduce_267),-	(268 , happyReduce_268),-	(269 , happyReduce_269),-	(270 , happyReduce_270),-	(271 , happyReduce_271),-	(272 , happyReduce_272),-	(273 , happyReduce_273),-	(274 , happyReduce_274),-	(275 , happyReduce_275),-	(276 , happyReduce_276),-	(277 , happyReduce_277),-	(278 , happyReduce_278),-	(279 , happyReduce_279),-	(280 , happyReduce_280),-	(281 , happyReduce_281),-	(282 , happyReduce_282),-	(283 , happyReduce_283),-	(284 , happyReduce_284),-	(285 , happyReduce_285),-	(286 , happyReduce_286),-	(287 , happyReduce_287),-	(288 , happyReduce_288),-	(289 , happyReduce_289),-	(290 , happyReduce_290),-	(291 , happyReduce_291),-	(292 , happyReduce_292),-	(293 , happyReduce_293),-	(294 , happyReduce_294),-	(295 , happyReduce_295),-	(296 , happyReduce_296),-	(297 , happyReduce_297),-	(298 , happyReduce_298),-	(299 , happyReduce_299),-	(300 , happyReduce_300),-	(301 , happyReduce_301),-	(302 , happyReduce_302),-	(303 , happyReduce_303),-	(304 , happyReduce_304),-	(305 , happyReduce_305),-	(306 , happyReduce_306),-	(307 , happyReduce_307),-	(308 , happyReduce_308),-	(309 , happyReduce_309),-	(310 , happyReduce_310),-	(311 , happyReduce_311),-	(312 , happyReduce_312),-	(313 , happyReduce_313),-	(314 , happyReduce_314),-	(315 , happyReduce_315),-	(316 , happyReduce_316),-	(317 , happyReduce_317),-	(318 , happyReduce_318),-	(319 , happyReduce_319),-	(320 , happyReduce_320),-	(321 , happyReduce_321),-	(322 , happyReduce_322),-	(323 , happyReduce_323),-	(324 , happyReduce_324),-	(325 , happyReduce_325),-	(326 , happyReduce_326),-	(327 , happyReduce_327),-	(328 , happyReduce_328),-	(329 , happyReduce_329),-	(330 , happyReduce_330),-	(331 , happyReduce_331),-	(332 , happyReduce_332),-	(333 , happyReduce_333),-	(334 , happyReduce_334),-	(335 , happyReduce_335),-	(336 , happyReduce_336),-	(337 , happyReduce_337),-	(338 , happyReduce_338),-	(339 , happyReduce_339),-	(340 , happyReduce_340),-	(341 , happyReduce_341),-	(342 , happyReduce_342),-	(343 , happyReduce_343),-	(344 , happyReduce_344),-	(345 , happyReduce_345),-	(346 , happyReduce_346),-	(347 , happyReduce_347),-	(348 , happyReduce_348),-	(349 , happyReduce_349),-	(350 , happyReduce_350),-	(351 , happyReduce_351),-	(352 , happyReduce_352),-	(353 , happyReduce_353),-	(354 , happyReduce_354),-	(355 , happyReduce_355),-	(356 , happyReduce_356)-	]--happy_n_terms = 83 :: Int-happy_n_nonterms = 138 :: Int--happyReduce_2 = happySpecReduce_2  0# happyReduction_2-happyReduction_2 happy_x_2-	happy_x_1-	 =  case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut6 happy_x_2 of { happy_var_2 -> -	happyIn5-		 (happy_var_2 { hsModuleSrcLoc = happy_var_1, hsModuleOptions = [] }-	)}}--happyReduce_3 = happySpecReduce_3  0# happyReduction_3-happyReduction_3 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (PragmaOptions happy_var_2) -> -	case happyOut5 happy_x_3 of { happy_var_3 -> -	happyIn5-		 (happy_var_3 { hsModuleSrcLoc = happy_var_1, hsModuleOptions = hsModuleOptions happy_var_3 ++ happy_var_2 }-	)}}}--happyReduce_4 = happyReduce 5# 1# happyReduction_4-happyReduction_4 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut137 happy_x_2 of { happy_var_2 -> -	case happyOut10 happy_x_3 of { happy_var_3 -> -	case happyOut7 happy_x_5 of { happy_var_5 -> -	happyIn6-		 (HsModule { hsModuleName = happy_var_2, hsModuleExports = happy_var_3, hsModuleImports = (fst happy_var_5), hsModuleDecls = (snd happy_var_5)-                                                                 , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" }-	) `HappyStk` happyRest}}}--happyReduce_5 = happySpecReduce_1  1# happyReduction_5-happyReduction_5 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn6-		 (HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (UnQual (HsIdent "main"))], hsModuleImports = (fst happy_var_1), hsModuleDecls = (snd happy_var_1)-                                                                 , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" }-	)}--happyReduce_6 = happySpecReduce_3  2# happyReduction_6-happyReduction_6 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut8 happy_x_2 of { happy_var_2 -> -	happyIn7-		 (happy_var_2-	)}--happyReduce_7 = happySpecReduce_3  2# happyReduction_7-happyReduction_7 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut8 happy_x_2 of { happy_var_2 -> -	happyIn7-		 (happy_var_2-	)}--happyReduce_8 = happyReduce 4# 3# happyReduction_8-happyReduction_8 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut17 happy_x_1 of { happy_var_1 -> -	case happyOut31 happy_x_3 of { happy_var_3 -> -	happyIn8-		 ((reverse happy_var_1, fixupHsDecls (reverse happy_var_3))-	) `HappyStk` happyRest}}--happyReduce_9 = happySpecReduce_2  3# happyReduction_9-happyReduction_9 happy_x_2-	happy_x_1-	 =  case happyOut31 happy_x_1 of { happy_var_1 -> -	happyIn8-		 (([], fixupHsDecls (reverse happy_var_1))-	)}--happyReduce_10 = happySpecReduce_2  3# happyReduction_10-happyReduction_10 happy_x_2-	happy_x_1-	 =  case happyOut17 happy_x_1 of { happy_var_1 -> -	happyIn8-		 ((reverse happy_var_1, [])-	)}--happyReduce_11 = happySpecReduce_0  3# happyReduction_11-happyReduction_11  =  happyIn8-		 (([], [])-	)--happyReduce_12 = happySpecReduce_1  4# happyReduction_12-happyReduction_12 happy_x_1-	 =  happyIn9-		 (()-	)--happyReduce_13 = happySpecReduce_0  4# happyReduction_13-happyReduction_13  =  happyIn9-		 (()-	)--happyReduce_14 = happySpecReduce_1  5# happyReduction_14-happyReduction_14 happy_x_1-	 =  case happyOut11 happy_x_1 of { happy_var_1 -> -	happyIn10-		 (Just happy_var_1-	)}--happyReduce_15 = happySpecReduce_0  5# happyReduction_15-happyReduction_15  =  happyIn10-		 (Nothing-	)--happyReduce_16 = happyReduce 4# 6# happyReduction_16-happyReduction_16 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut13 happy_x_2 of { happy_var_2 -> -	happyIn11-		 (reverse happy_var_2-	) `HappyStk` happyRest}--happyReduce_17 = happySpecReduce_2  6# happyReduction_17-happyReduction_17 happy_x_2-	happy_x_1-	 =  happyIn11-		 ([]-	)--happyReduce_18 = happySpecReduce_1  7# happyReduction_18-happyReduction_18 happy_x_1-	 =  happyIn12-		 (()-	)--happyReduce_19 = happySpecReduce_0  7# happyReduction_19-happyReduction_19  =  happyIn12-		 (()-	)--happyReduce_20 = happySpecReduce_3  8# happyReduction_20-happyReduction_20 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut13 happy_x_1 of { happy_var_1 -> -	case happyOut14 happy_x_3 of { happy_var_3 -> -	happyIn13-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_21 = happySpecReduce_1  8# happyReduction_21-happyReduction_21 happy_x_1-	 =  case happyOut14 happy_x_1 of { happy_var_1 -> -	happyIn13-		 ([happy_var_1]-	)}--happyReduce_22 = happySpecReduce_1  9# happyReduction_22-happyReduction_22 happy_x_1-	 =  case happyOut111 happy_x_1 of { happy_var_1 -> -	happyIn14-		 (HsEVar happy_var_1-	)}--happyReduce_23 = happySpecReduce_1  9# happyReduction_23-happyReduction_23 happy_x_1-	 =  case happyOut140 happy_x_1 of { happy_var_1 -> -	happyIn14-		 (HsEAbs happy_var_1-	)}--happyReduce_24 = happyReduce 4# 9# happyReduction_24-happyReduction_24 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut140 happy_x_1 of { happy_var_1 -> -	happyIn14-		 (HsEThingAll happy_var_1-	) `HappyStk` happyRest}--happyReduce_25 = happySpecReduce_3  9# happyReduction_25-happyReduction_25 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut140 happy_x_1 of { happy_var_1 -> -	happyIn14-		 (HsEThingWith happy_var_1 []-	)}--happyReduce_26 = happyReduce 4# 9# happyReduction_26-happyReduction_26 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut140 happy_x_1 of { happy_var_1 -> -	case happyOut15 happy_x_3 of { happy_var_3 -> -	happyIn14-		 (HsEThingWith happy_var_1 (reverse happy_var_3)-	) `HappyStk` happyRest}}--happyReduce_27 = happySpecReduce_2  9# happyReduction_27-happyReduction_27 happy_x_2-	happy_x_1-	 =  case happyOut137 happy_x_2 of { happy_var_2 -> -	happyIn14-		 (HsEModuleContents happy_var_2-	)}--happyReduce_28 = happySpecReduce_3  10# happyReduction_28-happyReduction_28 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut15 happy_x_1 of { happy_var_1 -> -	case happyOut16 happy_x_3 of { happy_var_3 -> -	happyIn15-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_29 = happySpecReduce_1  10# happyReduction_29-happyReduction_29 happy_x_1-	 =  case happyOut16 happy_x_1 of { happy_var_1 -> -	happyIn15-		 ([happy_var_1]-	)}--happyReduce_30 = happySpecReduce_1  11# happyReduction_30-happyReduction_30 happy_x_1-	 =  case happyOut111 happy_x_1 of { happy_var_1 -> -	happyIn16-		 (happy_var_1-	)}--happyReduce_31 = happySpecReduce_1  11# happyReduction_31-happyReduction_31 happy_x_1-	 =  case happyOut113 happy_x_1 of { happy_var_1 -> -	happyIn16-		 (happy_var_1-	)}--happyReduce_32 = happySpecReduce_3  12# happyReduction_32-happyReduction_32 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut17 happy_x_1 of { happy_var_1 -> -	case happyOut18 happy_x_3 of { happy_var_3 -> -	happyIn17-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_33 = happySpecReduce_1  12# happyReduction_33-happyReduction_33 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn17-		 ([happy_var_1]-	)}--happyReduce_34 = happyReduce 6# 13# happyReduction_34-happyReduction_34 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut19 happy_x_3 of { happy_var_3 -> -	case happyOut137 happy_x_4 of { happy_var_4 -> -	case happyOut20 happy_x_5 of { happy_var_5 -> -	case happyOut21 happy_x_6 of { happy_var_6 -> -	happyIn18-		 (HsImportDecl happy_var_2 happy_var_4 happy_var_3 happy_var_5 happy_var_6-	) `HappyStk` happyRest}}}}}--happyReduce_35 = happySpecReduce_1  14# happyReduction_35-happyReduction_35 happy_x_1-	 =  happyIn19-		 (True-	)--happyReduce_36 = happySpecReduce_0  14# happyReduction_36-happyReduction_36  =  happyIn19-		 (False-	)--happyReduce_37 = happySpecReduce_2  15# happyReduction_37-happyReduction_37 happy_x_2-	happy_x_1-	 =  case happyOut137 happy_x_2 of { happy_var_2 -> -	happyIn20-		 (Just happy_var_2-	)}--happyReduce_38 = happySpecReduce_0  15# happyReduction_38-happyReduction_38  =  happyIn20-		 (Nothing-	)--happyReduce_39 = happySpecReduce_1  16# happyReduction_39-happyReduction_39 happy_x_1-	 =  case happyOut22 happy_x_1 of { happy_var_1 -> -	happyIn21-		 (Just happy_var_1-	)}--happyReduce_40 = happySpecReduce_0  16# happyReduction_40-happyReduction_40  =  happyIn21-		 (Nothing-	)--happyReduce_41 = happyReduce 4# 17# happyReduction_41-happyReduction_41 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut23 happy_x_2 of { happy_var_2 -> -	happyIn22-		 ((False, reverse happy_var_2)-	) `HappyStk` happyRest}--happyReduce_42 = happySpecReduce_2  17# happyReduction_42-happyReduction_42 happy_x_2-	happy_x_1-	 =  happyIn22-		 ((False, [])-	)--happyReduce_43 = happyReduce 5# 17# happyReduction_43-happyReduction_43 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut23 happy_x_3 of { happy_var_3 -> -	happyIn22-		 ((True,  reverse happy_var_3)-	) `HappyStk` happyRest}--happyReduce_44 = happySpecReduce_3  18# happyReduction_44-happyReduction_44 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut23 happy_x_1 of { happy_var_1 -> -	case happyOut24 happy_x_3 of { happy_var_3 -> -	happyIn23-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_45 = happySpecReduce_1  18# happyReduction_45-happyReduction_45 happy_x_1-	 =  case happyOut24 happy_x_1 of { happy_var_1 -> -	happyIn23-		 ([happy_var_1]-	)}--happyReduce_46 = happySpecReduce_1  19# happyReduction_46-happyReduction_46 happy_x_1-	 =  case happyOut110 happy_x_1 of { happy_var_1 -> -	happyIn24-		 (HsIVar happy_var_1-	)}--happyReduce_47 = happySpecReduce_1  19# happyReduction_47-happyReduction_47 happy_x_1-	 =  case happyOut138 happy_x_1 of { happy_var_1 -> -	happyIn24-		 (HsIAbs happy_var_1-	)}--happyReduce_48 = happyReduce 4# 19# happyReduction_48-happyReduction_48 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut138 happy_x_1 of { happy_var_1 -> -	happyIn24-		 (HsIThingAll happy_var_1-	) `HappyStk` happyRest}--happyReduce_49 = happySpecReduce_3  19# happyReduction_49-happyReduction_49 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut138 happy_x_1 of { happy_var_1 -> -	happyIn24-		 (HsIThingWith happy_var_1 []-	)}--happyReduce_50 = happyReduce 4# 19# happyReduction_50-happyReduction_50 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut138 happy_x_1 of { happy_var_1 -> -	case happyOut25 happy_x_3 of { happy_var_3 -> -	happyIn24-		 (HsIThingWith happy_var_1 (reverse happy_var_3)-	) `HappyStk` happyRest}}--happyReduce_51 = happySpecReduce_3  20# happyReduction_51-happyReduction_51 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_1 of { happy_var_1 -> -	case happyOut26 happy_x_3 of { happy_var_3 -> -	happyIn25-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_52 = happySpecReduce_1  20# happyReduction_52-happyReduction_52 happy_x_1-	 =  case happyOut26 happy_x_1 of { happy_var_1 -> -	happyIn25-		 ([happy_var_1]-	)}--happyReduce_53 = happySpecReduce_1  21# happyReduction_53-happyReduction_53 happy_x_1-	 =  case happyOut110 happy_x_1 of { happy_var_1 -> -	happyIn26-		 (happy_var_1-	)}--happyReduce_54 = happySpecReduce_1  21# happyReduction_54-happyReduction_54 happy_x_1-	 =  case happyOut112 happy_x_1 of { happy_var_1 -> -	happyIn26-		 (happy_var_1-	)}--happyReduce_55 = happyReduce 4# 22# happyReduction_55-happyReduction_55 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut29 happy_x_2 of { happy_var_2 -> -	case happyOut28 happy_x_3 of { happy_var_3 -> -	case happyOut30 happy_x_4 of { happy_var_4 -> -	happyIn27-		 (HsInfixDecl happy_var_1 happy_var_2 happy_var_3 (reverse happy_var_4)-	) `HappyStk` happyRest}}}}--happyReduce_56 = happySpecReduce_0  23# happyReduction_56-happyReduction_56  =  happyIn28-		 (9-	)--happyReduce_57 = happyMonadReduce 1# 23# happyReduction_57-happyReduction_57 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (IntTok happy_var_1) -> -	(  checkPrec happy_var_1 `thenP` \p ->-                                                  returnP (fromInteger (readInteger p)))}-	) (\r -> happyReturn (happyIn28 r))--happyReduce_58 = happySpecReduce_1  24# happyReduction_58-happyReduction_58 happy_x_1-	 =  happyIn29-		 (HsAssocNone-	)--happyReduce_59 = happySpecReduce_1  24# happyReduction_59-happyReduction_59 happy_x_1-	 =  happyIn29-		 (HsAssocLeft-	)--happyReduce_60 = happySpecReduce_1  24# happyReduction_60-happyReduction_60 happy_x_1-	 =  happyIn29-		 (HsAssocRight-	)--happyReduce_61 = happySpecReduce_3  25# happyReduction_61-happyReduction_61 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut30 happy_x_1 of { happy_var_1 -> -	case happyOut119 happy_x_3 of { happy_var_3 -> -	happyIn30-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_62 = happySpecReduce_1  25# happyReduction_62-happyReduction_62 happy_x_1-	 =  case happyOut119 happy_x_1 of { happy_var_1 -> -	happyIn30-		 ([happy_var_1]-	)}--happyReduce_63 = happySpecReduce_3  26# happyReduction_63-happyReduction_63 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut31 happy_x_1 of { happy_var_1 -> -	case happyOut32 happy_x_3 of { happy_var_3 -> -	happyIn31-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_64 = happySpecReduce_1  26# happyReduction_64-happyReduction_64 happy_x_1-	 =  case happyOut32 happy_x_1 of { happy_var_1 -> -	happyIn31-		 ([happy_var_1]-	)}--happyReduce_65 = happyMonadReduce 4# 27# happyReduction_65-happyReduction_65 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut55 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut71 happy_x_4 of { happy_var_4 -> -	( checkDataHeader happy_var_2 `thenP` \(cs,c,t) ->-             returnP hsDataDecl { hsDeclSrcLoc = happy_var_3, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = happy_var_4 })}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_66 = happyMonadReduce 6# 27# happyReduction_66-happyReduction_66 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut55 happy_x_2 of { happy_var_2 -> -	case happyOut49 happy_x_4 of { happy_var_4 -> -	case happyOut134 happy_x_5 of { happy_var_5 -> -	case happyOut71 happy_x_6 of { happy_var_6 -> -	( checkDataHeader happy_var_2 `thenP` \(cs,c,t) ->-             returnP hsDataDecl { hsDeclSrcLoc = happy_var_5, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = happy_var_6, hsDeclHasKind = Just happy_var_4 })}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_67 = happyMonadReduce 6# 27# happyReduction_67-happyReduction_67 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut55 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut61 happy_x_5 of { happy_var_5 -> -	case happyOut71 happy_x_6 of { happy_var_6 -> -	( checkDataHeader happy_var_2 `thenP` \(cs,c,t) ->-                         returnP hsDataDecl { hsDeclSrcLoc = happy_var_3, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = happy_var_6, hsDeclCons = reverse happy_var_5 })}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_68 = happyMonadReduce 7# 27# happyReduction_68-happyReduction_68 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut55 happy_x_3 of { happy_var_3 -> -	case happyOut134 happy_x_4 of { happy_var_4 -> -	case happyOut61 happy_x_6 of { happy_var_6 -> -	case happyOut71 happy_x_7 of { happy_var_7 -> -	( checkDataHeader happy_var_3 `thenP` \(cs,c,t) ->-                         returnP hsDataDecl { hsDeclKindDecl = True, hsDeclSrcLoc = happy_var_4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = happy_var_7, hsDeclCons = reverse happy_var_6 })}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_69 = happyMonadReduce 6# 27# happyReduction_69-happyReduction_69 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut55 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut62 happy_x_5 of { happy_var_5 -> -	case happyOut71 happy_x_6 of { happy_var_6 -> -	( checkDataHeader happy_var_2 `thenP` \(cs,c,t) ->-                         returnP (HsNewTypeDecl happy_var_3 cs c t happy_var_5 happy_var_6))}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_70 = happyReduce 5# 27# happyReduction_70-happyReduction_70 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut55 happy_x_3 of { happy_var_3 -> -	case happyOut73 happy_x_5 of { happy_var_5 -> -	happyIn32-		 (HsClassDecl happy_var_2 happy_var_3 happy_var_5-	) `HappyStk` happyRest}}}--happyReduce_71 = happyMonadReduce 8# 27# happyReduction_71-happyReduction_71 (happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut125 happy_x_4 of { happy_var_4 -> -	case happyOut78 happy_x_5 of { happy_var_5 -> -	case happyOut56 happy_x_7 of { happy_var_7 -> -	case happyOut73 happy_x_8 of { happy_var_8 -> -	( let-                         { (cxt, clss) = happy_var_7;-                           ret = HsClassAliasDecl { hsDeclSrcLoc = happy_var_3, hsDeclName = happy_var_4, hsDeclTypeArgs = map HsTyVar happy_var_5, hsDeclContext = cxt, hsDeclClasses = clss, hsDeclDecls =happy_var_8 }-                         } in trace ("\n"++show ret++"\n") (return ret))}}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_72 = happyReduce 4# 27# happyReduction_72-happyReduction_72 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut55 happy_x_3 of { happy_var_3 -> -	case happyOut79 happy_x_4 of { happy_var_4 -> -	happyIn32-		 (HsInstDecl happy_var_2 happy_var_3 happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_73 = happyReduce 4# 27# happyReduction_73-happyReduction_73 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut57 happy_x_4 of { happy_var_4 -> -	happyIn32-		 (HsDeclDeriving happy_var_3 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_74 = happySpecReduce_3  27# happyReduction_74-happyReduction_74 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut46 happy_x_3 of { happy_var_3 -> -	happyIn32-		 (HsDefaultDecl happy_var_2 happy_var_3-	)}}--happyReduce_75 = happyMonadReduce 4# 27# happyReduction_75-happyReduction_75 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut85 happy_x_4 of { happy_var_4 -> -	( checkPattern happy_var_1 `thenP` \p ->-                                         returnP (HsActionDecl happy_var_2 p happy_var_4))}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_76 = happyMonadReduce 7# 27# happyReduction_76-happyReduction_76 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut78 happy_x_4 of { happy_var_4 -> -	case happyOut45 happy_x_5 of { happy_var_5 -> -	case happyOut55 happy_x_7 of { happy_var_7 -> -	( doForeign happy_var_2 (UnQual (HsIdent "import"):reverse happy_var_4) happy_var_5 happy_var_7)}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_77 = happyMonadReduce 6# 27# happyReduction_77-happyReduction_77 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut78 happy_x_3 of { happy_var_3 -> -	case happyOut45 happy_x_4 of { happy_var_4 -> -	case happyOut55 happy_x_6 of { happy_var_6 -> -	( doForeign happy_var_2 (reverse happy_var_3) happy_var_4 happy_var_6)}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_78 = happyMonadReduce 8# 27# happyReduction_78-happyReduction_78 (happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut78 happy_x_3 of { happy_var_3 -> -	case happyOut45 happy_x_4 of { happy_var_4 -> -	case happyOut55 happy_x_6 of { happy_var_6 -> -	case happyOut85 happy_x_8 of { happy_var_8 -> -	( doForeignEq happy_var_2 (reverse happy_var_3) happy_var_4 happy_var_6 happy_var_8)}}}}}-	) (\r -> happyReturn (happyIn32 r))--happyReduce_79 = happySpecReduce_3  27# happyReduction_79-happyReduction_79 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (PragmaRules happy_var_1) -> -	case happyOut35 happy_x_2 of { happy_var_2 -> -	happyIn32-		 (HsPragmaRules $ map (\x -> x { hsRuleIsMeta = happy_var_1 }) (reverse happy_var_2)-	)}}--happyReduce_80 = happyReduce 6# 27# happyReduction_80-happyReduction_80 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (PragmaSpecialize happy_var_2) -> -	case happyOut110 happy_x_3 of { happy_var_3 -> -	case happyOut46 happy_x_5 of { happy_var_5 -> -	happyIn32-		 (HsPragmaSpecialize { hsDeclSrcLoc = happy_var_1, hsDeclBool = happy_var_2, hsDeclName = happy_var_3, hsDeclType = happy_var_5-                                           , hsDeclUniq = error "hsDeclUniq not set"  }-	) `HappyStk` happyRest}}}}--happyReduce_81 = happySpecReduce_1  27# happyReduction_81-happyReduction_81 happy_x_1-	 =  case happyOut40 happy_x_1 of { happy_var_1 -> -	happyIn32-		 (happy_var_1-	)}--happyReduce_82 = happyReduce 6# 28# happyReduction_82-happyReduction_82 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (StringTok happy_var_2) -> -	case happyOut36 happy_x_3 of { happy_var_3 -> -	case happyOut85 happy_x_4 of { happy_var_4 -> -	case happyOut85 happy_x_6 of { happy_var_6 -> -	happyIn33-		 (HsRule { hsRuleSrcLoc = happy_var_1, hsRuleString = happy_var_2, hsRuleFreeVars = happy_var_3, hsRuleLeftExpr = happy_var_4, hsRuleRightExpr = happy_var_6-                  , hsRuleIsMeta = error "hsRuleIsMeta not set"-                  , hsRuleIsMethod = False }-	) `HappyStk` happyRest}}}}}--happyReduce_83 = happySpecReduce_3  29# happyReduction_83-happyReduction_83 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut34 happy_x_1 of { happy_var_1 -> -	case happyOut33 happy_x_3 of { happy_var_3 -> -	happyIn34-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_84 = happySpecReduce_2  29# happyReduction_84-happyReduction_84 happy_x_2-	happy_x_1-	 =  case happyOut33 happy_x_1 of { happy_var_1 -> -	happyIn34-		 ([happy_var_1]-	)}--happyReduce_85 = happySpecReduce_3  30# happyReduction_85-happyReduction_85 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut34 happy_x_2 of { happy_var_2 -> -	happyIn35-		 (happy_var_2-	)}--happyReduce_86 = happySpecReduce_3  30# happyReduction_86-happyReduction_86 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut34 happy_x_2 of { happy_var_2 -> -	happyIn35-		 (happy_var_2-	)}--happyReduce_87 = happySpecReduce_3  31# happyReduction_87-happyReduction_87 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut37 happy_x_2 of { happy_var_2 -> -	happyIn36-		 (happy_var_2-	)}--happyReduce_88 = happySpecReduce_0  31# happyReduction_88-happyReduction_88  =  happyIn36-		 ([]-	)--happyReduce_89 = happyReduce 6# 32# happyReduction_89-happyReduction_89 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut37 happy_x_1 of { happy_var_1 -> -	case happyOut110 happy_x_3 of { happy_var_3 -> -	case happyOut46 happy_x_5 of { happy_var_5 -> -	happyIn37-		 ((happy_var_3,Just happy_var_5) : happy_var_1-	) `HappyStk` happyRest}}}--happyReduce_90 = happySpecReduce_2  32# happyReduction_90-happyReduction_90 happy_x_2-	happy_x_1-	 =  case happyOut37 happy_x_1 of { happy_var_1 -> -	case happyOut110 happy_x_2 of { happy_var_2 -> -	happyIn37-		 ((happy_var_2,Nothing) : happy_var_1-	)}}--happyReduce_91 = happySpecReduce_0  32# happyReduction_91-happyReduction_91  =  happyIn37-		 ([]-	)--happyReduce_92 = happySpecReduce_2  33# happyReduction_92-happyReduction_92 happy_x_2-	happy_x_1-	 =  case happyOut39 happy_x_1 of { happy_var_1 -> -	happyIn38-		 (fixupHsDecls ( reverse happy_var_1 )-	)}--happyReduce_93 = happySpecReduce_1  33# happyReduction_93-happyReduction_93 happy_x_1-	 =  happyIn38-		 ([]-	)--happyReduce_94 = happySpecReduce_3  34# happyReduction_94-happyReduction_94 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut39 happy_x_1 of { happy_var_1 -> -	case happyOut40 happy_x_3 of { happy_var_3 -> -	happyIn39-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_95 = happySpecReduce_1  34# happyReduction_95-happyReduction_95 happy_x_1-	 =  case happyOut40 happy_x_1 of { happy_var_1 -> -	happyIn39-		 ([happy_var_1]-	)}--happyReduce_96 = happySpecReduce_1  35# happyReduction_96-happyReduction_96 happy_x_1-	 =  case happyOut42 happy_x_1 of { happy_var_1 -> -	happyIn40-		 (happy_var_1-	)}--happyReduce_97 = happySpecReduce_1  35# happyReduction_97-happyReduction_97 happy_x_1-	 =  case happyOut27 happy_x_1 of { happy_var_1 -> -	happyIn40-		 (happy_var_1-	)}--happyReduce_98 = happySpecReduce_1  35# happyReduction_98-happyReduction_98 happy_x_1-	 =  case happyOut81 happy_x_1 of { happy_var_1 -> -	happyIn40-		 (happy_var_1-	)}--happyReduce_99 = happySpecReduce_1  35# happyReduction_99-happyReduction_99 happy_x_1-	 =  case happyOut43 happy_x_1 of { happy_var_1 -> -	happyIn40-		 (happy_var_1-	)}--happyReduce_100 = happySpecReduce_3  36# happyReduction_100-happyReduction_100 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { happy_var_2 -> -	happyIn41-		 (happy_var_2-	)}--happyReduce_101 = happySpecReduce_3  36# happyReduction_101-happyReduction_101 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { happy_var_2 -> -	happyIn41-		 (happy_var_2-	)}--happyReduce_102 = happyReduce 4# 37# happyReduction_102-happyReduction_102 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut44 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut55 happy_x_4 of { happy_var_4 -> -	happyIn42-		 (HsTypeSig happy_var_2 (reverse happy_var_1) happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_103 = happyReduce 4# 38# happyReduction_103-happyReduction_103 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (PragmaStart happy_var_1) -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut44 happy_x_3 of { happy_var_3 -> -	happyIn43-		 (HsPragmaProps happy_var_2 happy_var_1 happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_104 = happySpecReduce_3  39# happyReduction_104-happyReduction_104 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut44 happy_x_1 of { happy_var_1 -> -	case happyOut110 happy_x_3 of { happy_var_3 -> -	happyIn44-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_105 = happyMonadReduce 1# 39# happyReduction_105-happyReduction_105 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut111 happy_x_1 of { happy_var_1 -> -	( checkUnQual happy_var_1 `thenP` \n ->-                                         returnP [n])}-	) (\r -> happyReturn (happyIn44 r))--happyReduce_106 = happySpecReduce_2  40# happyReduction_106-happyReduction_106 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (StringTok happy_var_1) -> -	case happyOut110 happy_x_2 of { happy_var_2 -> -	happyIn45-		 (Just (happy_var_1,happy_var_2)-	)}}--happyReduce_107 = happySpecReduce_0  40# happyReduction_107-happyReduction_107  =  happyIn45-		 (Nothing-	)--happyReduce_108 = happySpecReduce_3  41# happyReduction_108-happyReduction_108 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut51 happy_x_1 of { happy_var_1 -> -	case happyOut46 happy_x_3 of { happy_var_3 -> -	happyIn46-		 (HsTyFun happy_var_1 happy_var_3-	)}}--happyReduce_109 = happySpecReduce_1  41# happyReduction_109-happyReduction_109 happy_x_1-	 =  case happyOut51 happy_x_1 of { happy_var_1 -> -	happyIn46-		 (happy_var_1-	)}--happyReduce_110 = happyReduce 4# 41# happyReduction_110-happyReduction_110 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut47 happy_x_2 of { happy_var_2 -> -	case happyOut55 happy_x_4 of { happy_var_4 -> -	happyIn46-		 (HsTyForall { hsTypeVars = reverse happy_var_2, hsTypeType = happy_var_4 }-	) `HappyStk` happyRest}}--happyReduce_111 = happyReduce 4# 41# happyReduction_111-happyReduction_111 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut47 happy_x_2 of { happy_var_2 -> -	case happyOut55 happy_x_4 of { happy_var_4 -> -	happyIn46-		 (HsTyExists { hsTypeVars = reverse happy_var_2, hsTypeType = happy_var_4 }-	) `HappyStk` happyRest}}--happyReduce_112 = happySpecReduce_2  42# happyReduction_112-happyReduction_112 happy_x_2-	happy_x_1-	 =  case happyOut47 happy_x_1 of { happy_var_1 -> -	case happyOut48 happy_x_2 of { happy_var_2 -> -	happyIn47-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_113 = happySpecReduce_1  42# happyReduction_113-happyReduction_113 happy_x_1-	 =  case happyOut48 happy_x_1 of { happy_var_1 -> -	happyIn47-		 ([happy_var_1]-	)}--happyReduce_114 = happySpecReduce_2  43# happyReduction_114-happyReduction_114 happy_x_2-	happy_x_1-	 =  case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut123 happy_x_2 of { happy_var_2 -> -	happyIn48-		 (hsTyVarBind { hsTyVarBindSrcLoc = happy_var_1, hsTyVarBindName = happy_var_2 }-	)}}--happyReduce_115 = happyReduce 6# 43# happyReduction_115-happyReduction_115 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut123 happy_x_3 of { happy_var_3 -> -	case happyOut49 happy_x_5 of { happy_var_5 -> -	happyIn48-		 (hsTyVarBind { hsTyVarBindSrcLoc = happy_var_1, hsTyVarBindName = happy_var_3, hsTyVarBindKind = Just happy_var_5 }-	) `HappyStk` happyRest}}}--happyReduce_116 = happySpecReduce_1  44# happyReduction_116-happyReduction_116 happy_x_1-	 =  case happyOut50 happy_x_1 of { happy_var_1 -> -	happyIn49-		 (happy_var_1-	)}--happyReduce_117 = happySpecReduce_3  44# happyReduction_117-happyReduction_117 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut50 happy_x_1 of { happy_var_1 -> -	case happyOut49 happy_x_3 of { happy_var_3 -> -	happyIn49-		 (HsKindFn happy_var_1 happy_var_3-	)}}--happyReduce_118 = happySpecReduce_3  45# happyReduction_118-happyReduction_118 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut49 happy_x_2 of { happy_var_2 -> -	happyIn50-		 (happy_var_2-	)}--happyReduce_119 = happySpecReduce_1  45# happyReduction_119-happyReduction_119 happy_x_1-	 =  happyIn50-		 (hsKindStar-	)--happyReduce_120 = happySpecReduce_1  45# happyReduction_120-happyReduction_120 happy_x_1-	 =  happyIn50-		 (hsKindHash-	)--happyReduce_121 = happySpecReduce_1  45# happyReduction_121-happyReduction_121 happy_x_1-	 =  happyIn50-		 (hsKindBang-	)--happyReduce_122 = happySpecReduce_1  45# happyReduction_122-happyReduction_122 happy_x_1-	 =  happyIn50-		 (hsKindStarBang-	)--happyReduce_123 = happySpecReduce_1  45# happyReduction_123-happyReduction_123 happy_x_1-	 =  happyIn50-		 (hsKindQuest-	)--happyReduce_124 = happySpecReduce_1  45# happyReduction_124-happyReduction_124 happy_x_1-	 =  happyIn50-		 (hsKindQuestQuest-	)--happyReduce_125 = happySpecReduce_1  45# happyReduction_125-happyReduction_125 happy_x_1-	 =  case happyOut124 happy_x_1 of { happy_var_1 -> -	happyIn50-		 (HsKind happy_var_1-	)}--happyReduce_126 = happySpecReduce_2  46# happyReduction_126-happyReduction_126 happy_x_2-	happy_x_1-	 =  case happyOut51 happy_x_1 of { happy_var_1 -> -	case happyOut52 happy_x_2 of { happy_var_2 -> -	happyIn51-		 (HsTyApp happy_var_1 happy_var_2-	)}}--happyReduce_127 = happySpecReduce_1  46# happyReduction_127-happyReduction_127 happy_x_1-	 =  case happyOut52 happy_x_1 of { happy_var_1 -> -	happyIn51-		 (happy_var_1-	)}--happyReduce_128 = happySpecReduce_1  47# happyReduction_128-happyReduction_128 happy_x_1-	 =  case happyOut54 happy_x_1 of { happy_var_1 -> -	happyIn52-		 (HsTyCon happy_var_1-	)}--happyReduce_129 = happySpecReduce_1  47# happyReduction_129-happyReduction_129 happy_x_1-	 =  case happyOut142 happy_x_1 of { happy_var_1 -> -	happyIn52-		 (HsTyVar happy_var_1-	)}--happyReduce_130 = happySpecReduce_3  47# happyReduction_130-happyReduction_130 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut58 happy_x_2 of { happy_var_2 -> -	happyIn52-		 (HsTyTuple (reverse happy_var_2)-	)}--happyReduce_131 = happySpecReduce_2  47# happyReduction_131-happyReduction_131 happy_x_2-	happy_x_1-	 =  happyIn52-		 (HsTyUnboxedTuple []-	)--happyReduce_132 = happySpecReduce_3  47# happyReduction_132-happyReduction_132 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut46 happy_x_2 of { happy_var_2 -> -	happyIn52-		 (HsTyUnboxedTuple [happy_var_2]-	)}--happyReduce_133 = happySpecReduce_3  47# happyReduction_133-happyReduction_133 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut58 happy_x_2 of { happy_var_2 -> -	happyIn52-		 (HsTyUnboxedTuple (reverse happy_var_2)-	)}--happyReduce_134 = happySpecReduce_3  47# happyReduction_134-happyReduction_134 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut46 happy_x_2 of { happy_var_2 -> -	happyIn52-		 (HsTyApp list_tycon happy_var_2-	)}--happyReduce_135 = happySpecReduce_3  47# happyReduction_135-happyReduction_135 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut53 happy_x_2 of { happy_var_2 -> -	happyIn52-		 (happy_var_2-	)}--happyReduce_136 = happyReduce 5# 47# happyReduction_136-happyReduction_136 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut46 happy_x_2 of { happy_var_2 -> -	case happyOut46 happy_x_4 of { happy_var_4 -> -	happyIn52-		 (HsTyEq happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_137 = happyReduce 4# 48# happyReduction_137-happyReduction_137 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut52 happy_x_2 of { happy_var_2 -> -	case happyOut49 happy_x_4 of { happy_var_4 -> -	happyIn53-		 (HsTyExpKind { hsTySrcLoc = happy_var_1, hsTyType = happy_var_2, hsTyKind = happy_var_4 }-	) `HappyStk` happyRest}}}--happyReduce_138 = happySpecReduce_1  48# happyReduction_138-happyReduction_138 happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	happyIn53-		 (happy_var_1-	)}--happyReduce_139 = happySpecReduce_1  49# happyReduction_139-happyReduction_139 happy_x_1-	 =  case happyOut124 happy_x_1 of { happy_var_1 -> -	happyIn54-		 (happy_var_1-	)}--happyReduce_140 = happySpecReduce_2  49# happyReduction_140-happyReduction_140 happy_x_2-	happy_x_1-	 =  happyIn54-		 (unit_tycon_name-	)--happyReduce_141 = happySpecReduce_3  49# happyReduction_141-happyReduction_141 happy_x_3-	happy_x_2-	happy_x_1-	 =  happyIn54-		 (fun_tycon_name-	)--happyReduce_142 = happySpecReduce_2  49# happyReduction_142-happyReduction_142 happy_x_2-	happy_x_1-	 =  happyIn54-		 (list_tycon_name-	)--happyReduce_143 = happySpecReduce_3  49# happyReduction_143-happyReduction_143 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut92 happy_x_2 of { happy_var_2 -> -	happyIn54-		 (tuple_tycon_name happy_var_2-	)}--happyReduce_144 = happyMonadReduce 3# 50# happyReduction_144-happyReduction_144 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> -	case happyOut46 happy_x_3 of { happy_var_3 -> -	( checkContext happy_var_1 `thenP` \c ->-                                         returnP (HsQualType c happy_var_3))}}-	) (\r -> happyReturn (happyIn55 r))--happyReduce_145 = happySpecReduce_1  50# happyReduction_145-happyReduction_145 happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	happyIn55-		 (HsQualType [] happy_var_1-	)}--happyReduce_146 = happyMonadReduce 3# 51# happyReduction_146-happyReduction_146 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> -	case happyOut51 happy_x_3 of { happy_var_3 -> -	( liftM2 (,)     (checkContext happy_var_1) (checkContext happy_var_3))}}-	) (\r -> happyReturn (happyIn56 r))--happyReduce_147 = happyMonadReduce 1# 51# happyReduction_147-happyReduction_147 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> -	( liftM ((,) []) (checkContext happy_var_1))}-	) (\r -> happyReturn (happyIn56 r))--happyReduce_148 = happyMonadReduce 1# 52# happyReduction_148-happyReduction_148 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut55 happy_x_1 of { happy_var_1 -> -	( qualTypeToClassHead happy_var_1)}-	) (\r -> happyReturn (happyIn57 r))--happyReduce_149 = happySpecReduce_3  53# happyReduction_149-happyReduction_149 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut58 happy_x_1 of { happy_var_1 -> -	case happyOut46 happy_x_3 of { happy_var_3 -> -	happyIn58-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_150 = happySpecReduce_3  53# happyReduction_150-happyReduction_150 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	case happyOut46 happy_x_3 of { happy_var_3 -> -	happyIn58-		 ([happy_var_3, happy_var_1]-	)}}--happyReduce_151 = happySpecReduce_2  54# happyReduction_151-happyReduction_151 happy_x_2-	happy_x_1-	 =  case happyOut139 happy_x_1 of { happy_var_1 -> -	case happyOut60 happy_x_2 of { happy_var_2 -> -	happyIn59-		 ((happy_var_1,reverse happy_var_2)-	)}}--happyReduce_152 = happySpecReduce_2  55# happyReduction_152-happyReduction_152 happy_x_2-	happy_x_1-	 =  case happyOut60 happy_x_1 of { happy_var_1 -> -	case happyOut52 happy_x_2 of { happy_var_2 -> -	happyIn60-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_153 = happySpecReduce_0  55# happyReduction_153-happyReduction_153  =  happyIn60-		 ([]-	)--happyReduce_154 = happySpecReduce_3  56# happyReduction_154-happyReduction_154 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut61 happy_x_1 of { happy_var_1 -> -	case happyOut62 happy_x_3 of { happy_var_3 -> -	happyIn61-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_155 = happySpecReduce_1  56# happyReduction_155-happyReduction_155 happy_x_1-	 =  case happyOut62 happy_x_1 of { happy_var_1 -> -	happyIn61-		 ([happy_var_1]-	)}--happyReduce_156 = happySpecReduce_3  57# happyReduction_156-happyReduction_156 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut63 happy_x_2 of { happy_var_2 -> -	case happyOut64 happy_x_3 of { happy_var_3 -> -	happyIn62-		 (HsConDecl { hsConDeclSrcLoc = happy_var_1, hsConDeclName = (fst happy_var_3), hsConDeclConArg = (snd happy_var_3), hsConDeclExists = happy_var_2 }-	)}}}--happyReduce_157 = happyReduce 5# 57# happyReduction_157-happyReduction_157 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut63 happy_x_2 of { happy_var_2 -> -	case happyOut67 happy_x_3 of { happy_var_3 -> -	case happyOut117 happy_x_4 of { happy_var_4 -> -	case happyOut67 happy_x_5 of { happy_var_5 -> -	happyIn62-		 (HsConDecl { hsConDeclSrcLoc = happy_var_1, hsConDeclName = happy_var_4, hsConDeclConArg = [happy_var_3,happy_var_5], hsConDeclExists = happy_var_2 }-	) `HappyStk` happyRest}}}}}--happyReduce_158 = happyReduce 6# 57# happyReduction_158-happyReduction_158 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_1 of { happy_var_1 -> -	case happyOut63 happy_x_2 of { happy_var_2 -> -	case happyOut112 happy_x_3 of { happy_var_3 -> -	case happyOut68 happy_x_5 of { happy_var_5 -> -	happyIn62-		 (HsRecDecl { hsConDeclSrcLoc = happy_var_1, hsConDeclName = happy_var_3, hsConDeclRecArg = (reverse happy_var_5), hsConDeclExists = happy_var_2 }-	) `HappyStk` happyRest}}}}--happyReduce_159 = happySpecReduce_3  58# happyReduction_159-happyReduction_159 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut47 happy_x_2 of { happy_var_2 -> -	happyIn63-		 (happy_var_2-	)}--happyReduce_160 = happySpecReduce_3  58# happyReduction_160-happyReduction_160 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut47 happy_x_2 of { happy_var_2 -> -	happyIn63-		 (happy_var_2-	)}--happyReduce_161 = happySpecReduce_0  58# happyReduction_161-happyReduction_161  =  happyIn63-		 ([]-	)--happyReduce_162 = happyMonadReduce 1# 59# happyReduction_162-happyReduction_162 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> -	( splitTyConApp happy_var_1 `thenP` \(c,ts) ->-                                         returnP (c,map HsUnBangedTy ts))}-	) (\r -> happyReturn (happyIn64 r))--happyReduce_163 = happySpecReduce_1  59# happyReduction_163-happyReduction_163 happy_x_1-	 =  case happyOut65 happy_x_1 of { happy_var_1 -> -	happyIn64-		 (happy_var_1-	)}--happyReduce_164 = happyMonadReduce 3# 60# happyReduction_164-happyReduction_164 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> -	case happyOut52 happy_x_3 of { happy_var_3 -> -	( splitTyConApp happy_var_1 `thenP` \(c,ts) ->-                                         returnP (c,map HsUnBangedTy ts++-                                                      [HsBangedTy happy_var_3]))}}-	) (\r -> happyReturn (happyIn65 r))--happyReduce_165 = happySpecReduce_2  60# happyReduction_165-happyReduction_165 happy_x_2-	happy_x_1-	 =  case happyOut65 happy_x_1 of { happy_var_1 -> -	case happyOut66 happy_x_2 of { happy_var_2 -> -	happyIn65-		 ((fst happy_var_1, snd happy_var_1 ++ [happy_var_2] )-	)}}--happyReduce_166 = happySpecReduce_1  61# happyReduction_166-happyReduction_166 happy_x_1-	 =  case happyOut52 happy_x_1 of { happy_var_1 -> -	happyIn66-		 (HsUnBangedTy happy_var_1-	)}--happyReduce_167 = happySpecReduce_2  61# happyReduction_167-happyReduction_167 happy_x_2-	happy_x_1-	 =  case happyOut52 happy_x_2 of { happy_var_2 -> -	happyIn66-		 (HsBangedTy   happy_var_2-	)}--happyReduce_168 = happySpecReduce_1  62# happyReduction_168-happyReduction_168 happy_x_1-	 =  case happyOut51 happy_x_1 of { happy_var_1 -> -	happyIn67-		 (HsUnBangedTy happy_var_1-	)}--happyReduce_169 = happySpecReduce_2  62# happyReduction_169-happyReduction_169 happy_x_2-	happy_x_1-	 =  case happyOut52 happy_x_2 of { happy_var_2 -> -	happyIn67-		 (HsBangedTy   happy_var_2-	)}--happyReduce_170 = happySpecReduce_3  63# happyReduction_170-happyReduction_170 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut68 happy_x_1 of { happy_var_1 -> -	case happyOut69 happy_x_3 of { happy_var_3 -> -	happyIn68-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_171 = happySpecReduce_1  63# happyReduction_171-happyReduction_171 happy_x_1-	 =  case happyOut69 happy_x_1 of { happy_var_1 -> -	happyIn68-		 ([happy_var_1]-	)}--happyReduce_172 = happySpecReduce_3  64# happyReduction_172-happyReduction_172 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut44 happy_x_1 of { happy_var_1 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	happyIn69-		 ((reverse happy_var_1, happy_var_3)-	)}}--happyReduce_173 = happySpecReduce_1  65# happyReduction_173-happyReduction_173 happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	happyIn70-		 (HsUnBangedTy happy_var_1-	)}--happyReduce_174 = happySpecReduce_2  65# happyReduction_174-happyReduction_174 happy_x_2-	happy_x_1-	 =  case happyOut52 happy_x_2 of { happy_var_2 -> -	happyIn70-		 (HsBangedTy   happy_var_2-	)}--happyReduce_175 = happySpecReduce_0  66# happyReduction_175-happyReduction_175  =  happyIn71-		 ([]-	)--happyReduce_176 = happySpecReduce_2  66# happyReduction_176-happyReduction_176 happy_x_2-	happy_x_1-	 =  case happyOut141 happy_x_2 of { happy_var_2 -> -	happyIn71-		 ([happy_var_2]-	)}--happyReduce_177 = happySpecReduce_3  66# happyReduction_177-happyReduction_177 happy_x_3-	happy_x_2-	happy_x_1-	 =  happyIn71-		 ([]-	)--happyReduce_178 = happyReduce 4# 66# happyReduction_178-happyReduction_178 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut72 happy_x_3 of { happy_var_3 -> -	happyIn71-		 (reverse happy_var_3-	) `HappyStk` happyRest}--happyReduce_179 = happySpecReduce_3  67# happyReduction_179-happyReduction_179 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut72 happy_x_1 of { happy_var_1 -> -	case happyOut141 happy_x_3 of { happy_var_3 -> -	happyIn72-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_180 = happySpecReduce_1  67# happyReduction_180-happyReduction_180 happy_x_1-	 =  case happyOut141 happy_x_1 of { happy_var_1 -> -	happyIn72-		 ([happy_var_1]-	)}--happyReduce_181 = happySpecReduce_2  68# happyReduction_181-happyReduction_181 happy_x_2-	happy_x_1-	 =  case happyOut41 happy_x_2 of { happy_var_2 -> -	happyIn73-		 (fixupHsDecls happy_var_2-	)}--happyReduce_182 = happySpecReduce_0  68# happyReduction_182-happyReduction_182  =  happyIn73-		 ([]-	)--happyReduce_183 = happySpecReduce_3  69# happyReduction_183-happyReduction_183 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut74 happy_x_1 of { happy_var_1 -> -	case happyOut81 happy_x_3 of { happy_var_3 -> -	happyIn74-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_184 = happySpecReduce_1  69# happyReduction_184-happyReduction_184 happy_x_1-	 =  case happyOut81 happy_x_1 of { happy_var_1 -> -	happyIn74-		 ([happy_var_1]-	)}--happyReduce_185 = happySpecReduce_0  70# happyReduction_185-happyReduction_185  =  happyIn75-		 ([]-	)--happyReduce_186 = happySpecReduce_2  70# happyReduction_186-happyReduction_186 happy_x_2-	happy_x_1-	 =  case happyOut76 happy_x_2 of { happy_var_2 -> -	happyIn75-		 (reverse happy_var_2-	)}--happyReduce_187 = happySpecReduce_3  71# happyReduction_187-happyReduction_187 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut76 happy_x_1 of { happy_var_1 -> -	case happyOut77 happy_x_3 of { happy_var_3 -> -	happyIn76-		 ((happy_var_3:happy_var_1)-	)}}--happyReduce_188 = happySpecReduce_1  71# happyReduction_188-happyReduction_188 happy_x_1-	 =  case happyOut77 happy_x_1 of { happy_var_1 -> -	happyIn76-		 ([happy_var_1]-	)}--happyReduce_189 = happySpecReduce_3  72# happyReduction_189-happyReduction_189 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut78 happy_x_1 of { happy_var_1 -> -	case happyOut78 happy_x_3 of { happy_var_3 -> -	happyIn77-		 ((happy_var_1,happy_var_3)-	)}}--happyReduce_190 = happySpecReduce_0  73# happyReduction_190-happyReduction_190  =  happyIn78-		 ([]-	)--happyReduce_191 = happySpecReduce_2  73# happyReduction_191-happyReduction_191 happy_x_2-	happy_x_1-	 =  case happyOut78 happy_x_1 of { happy_var_1 -> -	case happyOut123 happy_x_2 of { happy_var_2 -> -	happyIn78-		 ((happy_var_2:happy_var_1)-	)}}--happyReduce_192 = happyReduce 4# 74# happyReduction_192-happyReduction_192 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut80 happy_x_3 of { happy_var_3 -> -	happyIn79-		 (happy_var_3-	) `HappyStk` happyRest}--happyReduce_193 = happyReduce 4# 74# happyReduction_193-happyReduction_193 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut80 happy_x_3 of { happy_var_3 -> -	happyIn79-		 (happy_var_3-	) `HappyStk` happyRest}--happyReduce_194 = happySpecReduce_0  74# happyReduction_194-happyReduction_194  =  happyIn79-		 ([]-	)--happyReduce_195 = happySpecReduce_2  75# happyReduction_195-happyReduction_195 happy_x_2-	happy_x_1-	 =  case happyOut74 happy_x_1 of { happy_var_1 -> -	happyIn80-		 (fixupHsDecls (reverse happy_var_1)-	)}--happyReduce_196 = happySpecReduce_1  75# happyReduction_196-happyReduction_196 happy_x_1-	 =  happyIn80-		 ([]-	)--happyReduce_197 = happyReduce 5# 76# happyReduction_197-happyReduction_197 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut59 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut46 happy_x_5 of { happy_var_5 -> -	happyIn81-		 (HsTypeDecl happy_var_3 (fst happy_var_2) (snd happy_var_2) happy_var_5-	) `HappyStk` happyRest}}}--happyReduce_198 = happySpecReduce_3  76# happyReduction_198-happyReduction_198 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut59 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	happyIn81-		 (HsTypeDecl happy_var_3 (fst happy_var_2) (snd happy_var_2) HsTyAssoc-	)}}--happyReduce_199 = happyMonadReduce 3# 76# happyReduction_199-happyReduction_199 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut82 happy_x_3 of { happy_var_3 -> -	( checkValDef happy_var_2 happy_var_1 happy_var_3 [])}}}-	) (\r -> happyReturn (happyIn81 r))--happyReduce_200 = happyMonadReduce 5# 76# happyReduction_200-happyReduction_200 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut82 happy_x_3 of { happy_var_3 -> -	case happyOut41 happy_x_5 of { happy_var_5 -> -	( checkValDef happy_var_2 happy_var_1 happy_var_3 happy_var_5)}}}}-	) (\r -> happyReturn (happyIn81 r))--happyReduce_201 = happyMonadReduce 2# 77# happyReduction_201-happyReduction_201 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut85 happy_x_2 of { happy_var_2 -> -	( checkExpr happy_var_2 `thenP` \e ->-                                         returnP (HsUnGuardedRhs e))}-	) (\r -> happyReturn (happyIn82 r))--happyReduce_202 = happySpecReduce_1  77# happyReduction_202-happyReduction_202 happy_x_1-	 =  case happyOut83 happy_x_1 of { happy_var_1 -> -	happyIn82-		 (HsGuardedRhss  (reverse happy_var_1)-	)}--happyReduce_203 = happySpecReduce_2  78# happyReduction_203-happyReduction_203 happy_x_2-	happy_x_1-	 =  case happyOut83 happy_x_1 of { happy_var_1 -> -	case happyOut84 happy_x_2 of { happy_var_2 -> -	happyIn83-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_204 = happySpecReduce_1  78# happyReduction_204-happyReduction_204 happy_x_1-	 =  case happyOut84 happy_x_1 of { happy_var_1 -> -	happyIn83-		 ([happy_var_1]-	)}--happyReduce_205 = happyMonadReduce 5# 79# happyReduction_205-happyReduction_205 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut85 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut85 happy_x_5 of { happy_var_5 -> -	( checkExpr happy_var_2 `thenP` \g ->-                                         checkExpr happy_var_5 `thenP` \e ->-                                         returnP (HsGuardedRhs happy_var_3 g e))}}}-	) (\r -> happyReturn (happyIn84 r))--happyReduce_206 = happyReduce 4# 80# happyReduction_206-happyReduction_206 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut55 happy_x_4 of { happy_var_4 -> -	happyIn85-		 (HsExpTypeSig happy_var_3 happy_var_1 happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_207 = happySpecReduce_1  80# happyReduction_207-happyReduction_207 happy_x_1-	 =  case happyOut86 happy_x_1 of { happy_var_1 -> -	happyIn85-		 (happy_var_1-	)}--happyReduce_208 = happySpecReduce_1  81# happyReduction_208-happyReduction_208 happy_x_1-	 =  case happyOut87 happy_x_1 of { happy_var_1 -> -	happyIn86-		 (happy_var_1-	)}--happyReduce_209 = happySpecReduce_3  81# happyReduction_209-happyReduction_209 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut120 happy_x_2 of { happy_var_2 -> -	case happyOut87 happy_x_3 of { happy_var_3 -> -	happyIn86-		 (HsInfixApp happy_var_1 happy_var_2 happy_var_3-	)}}}--happyReduce_210 = happyMonadReduce 5# 82# happyReduction_210-happyReduction_210 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut89 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut85 happy_x_5 of { happy_var_5 -> -	( checkPatterns (reverse happy_var_2) `thenP` \ps ->-                                         returnP (HsLambda happy_var_3 ps happy_var_5))}}}-	) (\r -> happyReturn (happyIn87 r))--happyReduce_211 = happyReduce 4# 82# happyReduction_211-happyReduction_211 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut41 happy_x_2 of { happy_var_2 -> -	case happyOut85 happy_x_4 of { happy_var_4 -> -	happyIn87-		 (HsLet happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_212 = happyReduce 8# 82# happyReduction_212-happyReduction_212 (happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut85 happy_x_2 of { happy_var_2 -> -	case happyOut85 happy_x_5 of { happy_var_5 -> -	case happyOut85 happy_x_8 of { happy_var_8 -> -	happyIn87-		 (HsIf happy_var_2 happy_var_5 happy_var_8-	) `HappyStk` happyRest}}}--happyReduce_213 = happyReduce 4# 82# happyReduction_213-happyReduction_213 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut85 happy_x_2 of { happy_var_2 -> -	case happyOut98 happy_x_4 of { happy_var_4 -> -	happyIn87-		 (HsCase happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_214 = happySpecReduce_2  82# happyReduction_214-happyReduction_214 happy_x_2-	happy_x_1-	 =  case happyOut88 happy_x_2 of { happy_var_2 -> -	happyIn87-		 (HsNegApp happy_var_2-	)}--happyReduce_215 = happySpecReduce_2  82# happyReduction_215-happyReduction_215 happy_x_2-	happy_x_1-	 =  case happyOut104 happy_x_2 of { happy_var_2 -> -	happyIn87-		 (HsDo happy_var_2-	)}--happyReduce_216 = happySpecReduce_1  82# happyReduction_216-happyReduction_216 happy_x_1-	 =  case happyOut88 happy_x_1 of { happy_var_1 -> -	happyIn87-		 (happy_var_1-	)}--happyReduce_217 = happySpecReduce_2  83# happyReduction_217-happyReduction_217 happy_x_2-	happy_x_1-	 =  case happyOut88 happy_x_1 of { happy_var_1 -> -	case happyOut90 happy_x_2 of { happy_var_2 -> -	happyIn88-		 (HsApp happy_var_1 happy_var_2-	)}}--happyReduce_218 = happySpecReduce_1  83# happyReduction_218-happyReduction_218 happy_x_1-	 =  case happyOut90 happy_x_1 of { happy_var_1 -> -	happyIn88-		 (happy_var_1-	)}--happyReduce_219 = happySpecReduce_2  84# happyReduction_219-happyReduction_219 happy_x_2-	happy_x_1-	 =  case happyOut89 happy_x_1 of { happy_var_1 -> -	case happyOut90 happy_x_2 of { happy_var_2 -> -	happyIn89-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_220 = happySpecReduce_1  84# happyReduction_220-happyReduction_220 happy_x_1-	 =  case happyOut90 happy_x_1 of { happy_var_1 -> -	happyIn89-		 ([happy_var_1]-	)}--happyReduce_221 = happyMonadReduce 4# 85# happyReduction_221-happyReduction_221 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut90 happy_x_1 of { happy_var_1 -> -	case happyOut107 happy_x_3 of { happy_var_3 -> -	( mkRecConstrOrUpdate happy_var_1 (reverse happy_var_3))}}-	) (\r -> happyReturn (happyIn90 r))--happyReduce_222 = happySpecReduce_1  85# happyReduction_222-happyReduction_222 happy_x_1-	 =  case happyOut91 happy_x_1 of { happy_var_1 -> -	happyIn90-		 (happy_var_1-	)}--happyReduce_223 = happySpecReduce_1  86# happyReduction_223-happyReduction_223 happy_x_1-	 =  case happyOut111 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (HsVar happy_var_1-	)}--happyReduce_224 = happySpecReduce_1  86# happyReduction_224-happyReduction_224 happy_x_1-	 =  case happyOut109 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (happy_var_1-	)}--happyReduce_225 = happySpecReduce_1  86# happyReduction_225-happyReduction_225 happy_x_1-	 =  case happyOut133 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (happy_var_1-	)}--happyReduce_226 = happySpecReduce_3  86# happyReduction_226-happyReduction_226 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_2 of { happy_var_2 -> -	happyIn91-		 (HsParen happy_var_2-	)}--happyReduce_227 = happySpecReduce_3  86# happyReduction_227-happyReduction_227 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut93 happy_x_2 of { happy_var_2 -> -	happyIn91-		 (HsTuple (reverse happy_var_2)-	)}--happyReduce_228 = happySpecReduce_2  86# happyReduction_228-happyReduction_228 happy_x_2-	happy_x_1-	 =  happyIn91-		 (HsUnboxedTuple []-	)--happyReduce_229 = happySpecReduce_3  86# happyReduction_229-happyReduction_229 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_2 of { happy_var_2 -> -	happyIn91-		 (HsUnboxedTuple [happy_var_2]-	)}--happyReduce_230 = happySpecReduce_3  86# happyReduction_230-happyReduction_230 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut93 happy_x_2 of { happy_var_2 -> -	happyIn91-		 (HsUnboxedTuple (reverse happy_var_2)-	)}--happyReduce_231 = happySpecReduce_3  86# happyReduction_231-happyReduction_231 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut94 happy_x_2 of { happy_var_2 -> -	happyIn91-		 (happy_var_2-	)}--happyReduce_232 = happyReduce 4# 86# happyReduction_232-happyReduction_232 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut86 happy_x_2 of { happy_var_2 -> -	case happyOut120 happy_x_3 of { happy_var_3 -> -	happyIn91-		 (HsLeftSection happy_var_3 happy_var_2-	) `HappyStk` happyRest}}--happyReduce_233 = happyReduce 4# 86# happyReduction_233-happyReduction_233 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut121 happy_x_2 of { happy_var_2 -> -	case happyOut86 happy_x_3 of { happy_var_3 -> -	happyIn91-		 (HsRightSection happy_var_3 happy_var_2-	) `HappyStk` happyRest}}--happyReduce_234 = happyMonadReduce 3# 86# happyReduction_234-happyReduction_234 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut111 happy_x_1 of { happy_var_1 -> -	case happyOut90 happy_x_3 of { happy_var_3 -> -	( checkUnQual happy_var_1 `thenP` \n ->-                                         returnP (HsAsPat n happy_var_3))}}-	) (\r -> happyReturn (happyIn91 r))--happyReduce_235 = happySpecReduce_2  86# happyReduction_235-happyReduction_235 happy_x_2-	happy_x_1-	 =  case happyOut134 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (HsWildCard happy_var_1-	)}--happyReduce_236 = happyReduce 4# 86# happyReduction_236-happyReduction_236 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut91 happy_x_3 of { happy_var_3 -> -	case happyOut134 happy_x_4 of { happy_var_4 -> -	happyIn91-		 (HsIrrPat $ located (happy_var_2,happy_var_4) happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_237 = happySpecReduce_2  87# happyReduction_237-happyReduction_237 happy_x_2-	happy_x_1-	 =  case happyOut92 happy_x_1 of { happy_var_1 -> -	happyIn92-		 (happy_var_1 + 1-	)}--happyReduce_238 = happySpecReduce_1  87# happyReduction_238-happyReduction_238 happy_x_1-	 =  happyIn92-		 (1-	)--happyReduce_239 = happySpecReduce_3  88# happyReduction_239-happyReduction_239 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut93 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn93-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_240 = happySpecReduce_3  88# happyReduction_240-happyReduction_240 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn93-		 ([happy_var_3,happy_var_1]-	)}}--happyReduce_241 = happySpecReduce_1  89# happyReduction_241-happyReduction_241 happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	happyIn94-		 (HsList [happy_var_1]-	)}--happyReduce_242 = happySpecReduce_1  89# happyReduction_242-happyReduction_242 happy_x_1-	 =  case happyOut95 happy_x_1 of { happy_var_1 -> -	happyIn94-		 (HsList (reverse happy_var_1)-	)}--happyReduce_243 = happySpecReduce_2  89# happyReduction_243-happyReduction_243 happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	happyIn94-		 (HsEnumFrom happy_var_1-	)}--happyReduce_244 = happyReduce 4# 89# happyReduction_244-happyReduction_244 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn94-		 (HsEnumFromThen happy_var_1 happy_var_3-	) `HappyStk` happyRest}}--happyReduce_245 = happySpecReduce_3  89# happyReduction_245-happyReduction_245 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn94-		 (HsEnumFromTo happy_var_1 happy_var_3-	)}}--happyReduce_246 = happyReduce 5# 89# happyReduction_246-happyReduction_246 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	case happyOut85 happy_x_5 of { happy_var_5 -> -	happyIn94-		 (HsEnumFromThenTo happy_var_1 happy_var_3 happy_var_5-	) `HappyStk` happyRest}}}--happyReduce_247 = happySpecReduce_3  89# happyReduction_247-happyReduction_247 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut96 happy_x_3 of { happy_var_3 -> -	happyIn94-		 (HsListComp happy_var_1 (reverse happy_var_3)-	)}}--happyReduce_248 = happySpecReduce_3  90# happyReduction_248-happyReduction_248 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut95 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn95-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_249 = happySpecReduce_3  90# happyReduction_249-happyReduction_249 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn95-		 ([happy_var_3,happy_var_1]-	)}}--happyReduce_250 = happySpecReduce_3  91# happyReduction_250-happyReduction_250 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut96 happy_x_1 of { happy_var_1 -> -	case happyOut97 happy_x_3 of { happy_var_3 -> -	happyIn96-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_251 = happySpecReduce_1  91# happyReduction_251-happyReduction_251 happy_x_1-	 =  case happyOut97 happy_x_1 of { happy_var_1 -> -	happyIn96-		 ([happy_var_1]-	)}--happyReduce_252 = happyMonadReduce 4# 92# happyReduction_252-happyReduction_252 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut85 happy_x_4 of { happy_var_4 -> -	( checkPattern happy_var_1 `thenP` \p ->-                                         returnP (HsGenerator happy_var_2 p happy_var_4))}}}-	) (\r -> happyReturn (happyIn97 r))--happyReduce_253 = happySpecReduce_1  92# happyReduction_253-happyReduction_253 happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	happyIn97-		 (HsQualifier happy_var_1-	)}--happyReduce_254 = happySpecReduce_2  92# happyReduction_254-happyReduction_254 happy_x_2-	happy_x_1-	 =  case happyOut41 happy_x_2 of { happy_var_2 -> -	happyIn97-		 (HsLetStmt happy_var_2-	)}--happyReduce_255 = happyReduce 4# 93# happyReduction_255-happyReduction_255 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut99 happy_x_2 of { happy_var_2 -> -	happyIn98-		 (reverse happy_var_2-	) `HappyStk` happyRest}--happyReduce_256 = happyReduce 4# 93# happyReduction_256-happyReduction_256 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut99 happy_x_2 of { happy_var_2 -> -	happyIn98-		 (reverse happy_var_2-	) `HappyStk` happyRest}--happyReduce_257 = happySpecReduce_3  94# happyReduction_257-happyReduction_257 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut99 happy_x_1 of { happy_var_1 -> -	case happyOut100 happy_x_3 of { happy_var_3 -> -	happyIn99-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_258 = happySpecReduce_1  94# happyReduction_258-happyReduction_258 happy_x_1-	 =  case happyOut100 happy_x_1 of { happy_var_1 -> -	happyIn99-		 ([happy_var_1]-	)}--happyReduce_259 = happyMonadReduce 3# 95# happyReduction_259-happyReduction_259 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut101 happy_x_3 of { happy_var_3 -> -	( checkPattern happy_var_1 `thenP` \p ->-                                 returnP (HsAlt happy_var_2 p happy_var_3 []))}}}-	) (\r -> happyReturn (happyIn100 r))--happyReduce_260 = happyMonadReduce 5# 95# happyReduction_260-happyReduction_260 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> -	case happyOut134 happy_x_2 of { happy_var_2 -> -	case happyOut101 happy_x_3 of { happy_var_3 -> -	case happyOut41 happy_x_5 of { happy_var_5 -> -	( checkPattern happy_var_1 `thenP` \p ->-                                 returnP (HsAlt happy_var_2 p happy_var_3 happy_var_5))}}}}-	) (\r -> happyReturn (happyIn100 r))--happyReduce_261 = happySpecReduce_2  96# happyReduction_261-happyReduction_261 happy_x_2-	happy_x_1-	 =  case happyOut85 happy_x_2 of { happy_var_2 -> -	happyIn101-		 (HsUnGuardedRhs happy_var_2-	)}--happyReduce_262 = happySpecReduce_1  96# happyReduction_262-happyReduction_262 happy_x_1-	 =  case happyOut102 happy_x_1 of { happy_var_1 -> -	happyIn101-		 (HsGuardedRhss (reverse happy_var_1)-	)}--happyReduce_263 = happySpecReduce_2  97# happyReduction_263-happyReduction_263 happy_x_2-	happy_x_1-	 =  case happyOut102 happy_x_1 of { happy_var_1 -> -	case happyOut103 happy_x_2 of { happy_var_2 -> -	happyIn102-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_264 = happySpecReduce_1  97# happyReduction_264-happyReduction_264 happy_x_1-	 =  case happyOut103 happy_x_1 of { happy_var_1 -> -	happyIn102-		 ([happy_var_1]-	)}--happyReduce_265 = happyReduce 5# 98# happyReduction_265-happyReduction_265 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut85 happy_x_2 of { happy_var_2 -> -	case happyOut134 happy_x_3 of { happy_var_3 -> -	case happyOut85 happy_x_5 of { happy_var_5 -> -	happyIn103-		 (HsGuardedRhs happy_var_3 happy_var_2 happy_var_5-	) `HappyStk` happyRest}}}--happyReduce_266 = happySpecReduce_3  99# happyReduction_266-happyReduction_266 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut105 happy_x_2 of { happy_var_2 -> -	happyIn104-		 (happy_var_2-	)}--happyReduce_267 = happySpecReduce_3  99# happyReduction_267-happyReduction_267 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut105 happy_x_2 of { happy_var_2 -> -	happyIn104-		 (happy_var_2-	)}--happyReduce_268 = happySpecReduce_3  100# happyReduction_268-happyReduction_268 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut106 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn105-		 (reverse (HsQualifier happy_var_3 : happy_var_1)-	)}}--happyReduce_269 = happySpecReduce_1  100# happyReduction_269-happyReduction_269 happy_x_1-	 =  case happyOut85 happy_x_1 of { happy_var_1 -> -	happyIn105-		 ([HsQualifier happy_var_1]-	)}--happyReduce_270 = happySpecReduce_3  101# happyReduction_270-happyReduction_270 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut106 happy_x_1 of { happy_var_1 -> -	case happyOut97 happy_x_3 of { happy_var_3 -> -	happyIn106-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_271 = happySpecReduce_1  101# happyReduction_271-happyReduction_271 happy_x_1-	 =  case happyOut97 happy_x_1 of { happy_var_1 -> -	happyIn106-		 ([happy_var_1]-	)}--happyReduce_272 = happySpecReduce_3  102# happyReduction_272-happyReduction_272 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut107 happy_x_1 of { happy_var_1 -> -	case happyOut108 happy_x_3 of { happy_var_3 -> -	happyIn107-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_273 = happySpecReduce_1  102# happyReduction_273-happyReduction_273 happy_x_1-	 =  case happyOut108 happy_x_1 of { happy_var_1 -> -	happyIn107-		 ([happy_var_1]-	)}--happyReduce_274 = happySpecReduce_3  103# happyReduction_274-happyReduction_274 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut111 happy_x_1 of { happy_var_1 -> -	case happyOut85 happy_x_3 of { happy_var_3 -> -	happyIn108-		 (HsFieldUpdate happy_var_1 happy_var_3-	)}}--happyReduce_275 = happySpecReduce_2  104# happyReduction_275-happyReduction_275 happy_x_2-	happy_x_1-	 =  happyIn109-		 (unit_con-	)--happyReduce_276 = happySpecReduce_2  104# happyReduction_276-happyReduction_276 happy_x_2-	happy_x_1-	 =  happyIn109-		 (HsList []-	)--happyReduce_277 = happySpecReduce_3  104# happyReduction_277-happyReduction_277 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut92 happy_x_2 of { happy_var_2 -> -	happyIn109-		 (tuple_con happy_var_2-	)}--happyReduce_278 = happySpecReduce_1  104# happyReduction_278-happyReduction_278 happy_x_1-	 =  case happyOut113 happy_x_1 of { happy_var_1 -> -	happyIn109-		 (HsCon happy_var_1-	)}--happyReduce_279 = happySpecReduce_1  105# happyReduction_279-happyReduction_279 happy_x_1-	 =  case happyOut123 happy_x_1 of { happy_var_1 -> -	happyIn110-		 (happy_var_1-	)}--happyReduce_280 = happySpecReduce_3  105# happyReduction_280-happyReduction_280 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut130 happy_x_2 of { happy_var_2 -> -	happyIn110-		 (happy_var_2-	)}--happyReduce_281 = happySpecReduce_1  106# happyReduction_281-happyReduction_281 happy_x_1-	 =  case happyOut122 happy_x_1 of { happy_var_1 -> -	happyIn111-		 (happy_var_1-	)}--happyReduce_282 = happySpecReduce_3  106# happyReduction_282-happyReduction_282 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut128 happy_x_2 of { happy_var_2 -> -	happyIn111-		 (happy_var_2-	)}--happyReduce_283 = happySpecReduce_1  107# happyReduction_283-happyReduction_283 happy_x_1-	 =  case happyOut125 happy_x_1 of { happy_var_1 -> -	happyIn112-		 (happy_var_1-	)}--happyReduce_284 = happySpecReduce_3  107# happyReduction_284-happyReduction_284 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut127 happy_x_2 of { happy_var_2 -> -	happyIn112-		 (happy_var_2-	)}--happyReduce_285 = happySpecReduce_1  108# happyReduction_285-happyReduction_285 happy_x_1-	 =  case happyOut124 happy_x_1 of { happy_var_1 -> -	happyIn113-		 (happy_var_1-	)}--happyReduce_286 = happySpecReduce_3  108# happyReduction_286-happyReduction_286 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut126 happy_x_2 of { happy_var_2 -> -	happyIn113-		 (happy_var_2-	)}--happyReduce_287 = happySpecReduce_1  109# happyReduction_287-happyReduction_287 happy_x_1-	 =  case happyOut130 happy_x_1 of { happy_var_1 -> -	happyIn114-		 (happy_var_1-	)}--happyReduce_288 = happySpecReduce_3  109# happyReduction_288-happyReduction_288 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut123 happy_x_2 of { happy_var_2 -> -	happyIn114-		 (happy_var_2-	)}--happyReduce_289 = happySpecReduce_1  110# happyReduction_289-happyReduction_289 happy_x_1-	 =  case happyOut128 happy_x_1 of { happy_var_1 -> -	happyIn115-		 (happy_var_1-	)}--happyReduce_290 = happySpecReduce_3  110# happyReduction_290-happyReduction_290 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut122 happy_x_2 of { happy_var_2 -> -	happyIn115-		 (happy_var_2-	)}--happyReduce_291 = happySpecReduce_1  111# happyReduction_291-happyReduction_291 happy_x_1-	 =  case happyOut129 happy_x_1 of { happy_var_1 -> -	happyIn116-		 (happy_var_1-	)}--happyReduce_292 = happySpecReduce_3  111# happyReduction_292-happyReduction_292 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut122 happy_x_2 of { happy_var_2 -> -	happyIn116-		 (happy_var_2-	)}--happyReduce_293 = happySpecReduce_1  112# happyReduction_293-happyReduction_293 happy_x_1-	 =  case happyOut127 happy_x_1 of { happy_var_1 -> -	happyIn117-		 (happy_var_1-	)}--happyReduce_294 = happySpecReduce_3  112# happyReduction_294-happyReduction_294 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut125 happy_x_2 of { happy_var_2 -> -	happyIn117-		 (happy_var_2-	)}--happyReduce_295 = happySpecReduce_1  113# happyReduction_295-happyReduction_295 happy_x_1-	 =  case happyOut126 happy_x_1 of { happy_var_1 -> -	happyIn118-		 (happy_var_1-	)}--happyReduce_296 = happySpecReduce_3  113# happyReduction_296-happyReduction_296 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut124 happy_x_2 of { happy_var_2 -> -	happyIn118-		 (happy_var_2-	)}--happyReduce_297 = happySpecReduce_1  114# happyReduction_297-happyReduction_297 happy_x_1-	 =  case happyOut114 happy_x_1 of { happy_var_1 -> -	happyIn119-		 (happy_var_1-	)}--happyReduce_298 = happySpecReduce_1  114# happyReduction_298-happyReduction_298 happy_x_1-	 =  case happyOut117 happy_x_1 of { happy_var_1 -> -	happyIn119-		 (happy_var_1-	)}--happyReduce_299 = happySpecReduce_1  115# happyReduction_299-happyReduction_299 happy_x_1-	 =  case happyOut115 happy_x_1 of { happy_var_1 -> -	happyIn120-		 (HsVar happy_var_1-	)}--happyReduce_300 = happySpecReduce_1  115# happyReduction_300-happyReduction_300 happy_x_1-	 =  case happyOut118 happy_x_1 of { happy_var_1 -> -	happyIn120-		 (HsCon happy_var_1-	)}--happyReduce_301 = happySpecReduce_1  116# happyReduction_301-happyReduction_301 happy_x_1-	 =  case happyOut116 happy_x_1 of { happy_var_1 -> -	happyIn121-		 (HsVar happy_var_1-	)}--happyReduce_302 = happySpecReduce_1  116# happyReduction_302-happyReduction_302 happy_x_1-	 =  case happyOut118 happy_x_1 of { happy_var_1 -> -	happyIn121-		 (HsCon happy_var_1-	)}--happyReduce_303 = happySpecReduce_1  117# happyReduction_303-happyReduction_303 happy_x_1-	 =  case happyOut123 happy_x_1 of { happy_var_1 -> -	happyIn122-		 (happy_var_1-	)}--happyReduce_304 = happySpecReduce_1  117# happyReduction_304-happyReduction_304 happy_x_1-	 =  case happyOutTok happy_x_1 of { (QVarId happy_var_1) -> -	happyIn122-		 (Qual (Module (fst happy_var_1)) (HsIdent (snd happy_var_1))-	)}--happyReduce_305 = happySpecReduce_1  118# happyReduction_305-happyReduction_305 happy_x_1-	 =  case happyOutTok happy_x_1 of { (VarId happy_var_1) -> -	happyIn123-		 (UnQual (HsIdent happy_var_1)-	)}--happyReduce_306 = happySpecReduce_1  118# happyReduction_306-happyReduction_306 happy_x_1-	 =  happyIn123-		 (as_name-	)--happyReduce_307 = happySpecReduce_1  118# happyReduction_307-happyReduction_307 happy_x_1-	 =  happyIn123-		 (UnQual (HsIdent "alias")-	)--happyReduce_308 = happySpecReduce_1  118# happyReduction_308-happyReduction_308 happy_x_1-	 =  happyIn123-		 (UnQual (HsIdent "kind")-	)--happyReduce_309 = happySpecReduce_1  118# happyReduction_309-happyReduction_309 happy_x_1-	 =  happyIn123-		 (qualified_name-	)--happyReduce_310 = happySpecReduce_1  118# happyReduction_310-happyReduction_310 happy_x_1-	 =  happyIn123-		 (hiding_name-	)--happyReduce_311 = happySpecReduce_1  118# happyReduction_311-happyReduction_311 happy_x_1-	 =  happyIn123-		 (UnQual (HsIdent "forall")-	)--happyReduce_312 = happySpecReduce_1  118# happyReduction_312-happyReduction_312 happy_x_1-	 =  happyIn123-		 (UnQual (HsIdent "exists")-	)--happyReduce_313 = happySpecReduce_1  118# happyReduction_313-happyReduction_313 happy_x_1-	 =  happyIn123-		 (derive_name-	)--happyReduce_314 = happySpecReduce_1  119# happyReduction_314-happyReduction_314 happy_x_1-	 =  case happyOut125 happy_x_1 of { happy_var_1 -> -	happyIn124-		 (happy_var_1-	)}--happyReduce_315 = happySpecReduce_1  119# happyReduction_315-happyReduction_315 happy_x_1-	 =  case happyOutTok happy_x_1 of { (QConId happy_var_1) -> -	happyIn124-		 (Qual (Module (fst happy_var_1)) (HsIdent (snd happy_var_1))-	)}--happyReduce_316 = happySpecReduce_1  120# happyReduction_316-happyReduction_316 happy_x_1-	 =  case happyOutTok happy_x_1 of { (ConId happy_var_1) -> -	happyIn125-		 (UnQual (HsIdent happy_var_1)-	)}--happyReduce_317 = happySpecReduce_1  121# happyReduction_317-happyReduction_317 happy_x_1-	 =  case happyOut127 happy_x_1 of { happy_var_1 -> -	happyIn126-		 (happy_var_1-	)}--happyReduce_318 = happySpecReduce_1  121# happyReduction_318-happyReduction_318 happy_x_1-	 =  case happyOutTok happy_x_1 of { (QConSym happy_var_1) -> -	happyIn126-		 (Qual (Module (fst happy_var_1)) (hsSymbol (snd happy_var_1))-	)}--happyReduce_319 = happySpecReduce_1  122# happyReduction_319-happyReduction_319 happy_x_1-	 =  case happyOutTok happy_x_1 of { (ConSym happy_var_1) -> -	happyIn127-		 (UnQual (hsSymbol happy_var_1)-	)}--happyReduce_320 = happySpecReduce_1  123# happyReduction_320-happyReduction_320 happy_x_1-	 =  case happyOut130 happy_x_1 of { happy_var_1 -> -	happyIn128-		 (happy_var_1-	)}--happyReduce_321 = happySpecReduce_1  123# happyReduction_321-happyReduction_321 happy_x_1-	 =  case happyOut132 happy_x_1 of { happy_var_1 -> -	happyIn128-		 (happy_var_1-	)}--happyReduce_322 = happySpecReduce_1  124# happyReduction_322-happyReduction_322 happy_x_1-	 =  case happyOut131 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_323 = happySpecReduce_1  124# happyReduction_323-happyReduction_323 happy_x_1-	 =  case happyOut132 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_324 = happySpecReduce_1  125# happyReduction_324-happyReduction_324 happy_x_1-	 =  case happyOutTok happy_x_1 of { (VarSym happy_var_1) -> -	happyIn130-		 (UnQual (hsSymbol happy_var_1)-	)}--happyReduce_325 = happySpecReduce_1  125# happyReduction_325-happyReduction_325 happy_x_1-	 =  happyIn130-		 (minus_name-	)--happyReduce_326 = happySpecReduce_1  125# happyReduction_326-happyReduction_326 happy_x_1-	 =  happyIn130-		 (pling_name-	)--happyReduce_327 = happySpecReduce_1  125# happyReduction_327-happyReduction_327 happy_x_1-	 =  happyIn130-		 (UnQual (hsSymbol "?")-	)--happyReduce_328 = happySpecReduce_1  125# happyReduction_328-happyReduction_328 happy_x_1-	 =  happyIn130-		 (UnQual (hsSymbol "??")-	)--happyReduce_329 = happySpecReduce_1  125# happyReduction_329-happyReduction_329 happy_x_1-	 =  happyIn130-		 (UnQual (hsSymbol "*!")-	)--happyReduce_330 = happySpecReduce_1  125# happyReduction_330-happyReduction_330 happy_x_1-	 =  happyIn130-		 (star_name-	)--happyReduce_331 = happySpecReduce_1  125# happyReduction_331-happyReduction_331 happy_x_1-	 =  happyIn130-		 (hash_name-	)--happyReduce_332 = happySpecReduce_1  125# happyReduction_332-happyReduction_332 happy_x_1-	 =  happyIn130-		 (dot_name-	)--happyReduce_333 = happySpecReduce_1  126# happyReduction_333-happyReduction_333 happy_x_1-	 =  case happyOutTok happy_x_1 of { (VarSym happy_var_1) -> -	happyIn131-		 (UnQual (hsSymbol happy_var_1)-	)}--happyReduce_334 = happySpecReduce_1  126# happyReduction_334-happyReduction_334 happy_x_1-	 =  happyIn131-		 (pling_name-	)--happyReduce_335 = happySpecReduce_1  126# happyReduction_335-happyReduction_335 happy_x_1-	 =  happyIn131-		 (star_name-	)--happyReduce_336 = happySpecReduce_1  126# happyReduction_336-happyReduction_336 happy_x_1-	 =  happyIn131-		 (hash_name-	)--happyReduce_337 = happySpecReduce_1  126# happyReduction_337-happyReduction_337 happy_x_1-	 =  happyIn131-		 (dot_name-	)--happyReduce_338 = happySpecReduce_1  127# happyReduction_338-happyReduction_338 happy_x_1-	 =  case happyOutTok happy_x_1 of { (QVarSym happy_var_1) -> -	happyIn132-		 (Qual (Module (fst happy_var_1)) (hsSymbol (snd happy_var_1))-	)}--happyReduce_339 = happySpecReduce_1  128# happyReduction_339-happyReduction_339 happy_x_1-	 =  case happyOutTok happy_x_1 of { (IntTok happy_var_1) -> -	happyIn133-		 (HsLit (HsInt (readInteger happy_var_1))-	)}--happyReduce_340 = happySpecReduce_1  128# happyReduction_340-happyReduction_340 happy_x_1-	 =  case happyOutTok happy_x_1 of { (UIntTok happy_var_1) -> -	happyIn133-		 (HsLit (HsIntPrim (readInteger happy_var_1))-	)}--happyReduce_341 = happySpecReduce_1  128# happyReduction_341-happyReduction_341 happy_x_1-	 =  case happyOutTok happy_x_1 of { (Character happy_var_1) -> -	happyIn133-		 (HsLit (HsChar happy_var_1)-	)}--happyReduce_342 = happySpecReduce_1  128# happyReduction_342-happyReduction_342 happy_x_1-	 =  case happyOutTok happy_x_1 of { (UCharacter happy_var_1) -> -	happyIn133-		 (HsLit (HsCharPrim happy_var_1)-	)}--happyReduce_343 = happySpecReduce_1  128# happyReduction_343-happyReduction_343 happy_x_1-	 =  case happyOutTok happy_x_1 of { (FloatTok happy_var_1) -> -	happyIn133-		 (HsLit (HsFrac (readRational happy_var_1))-	)}--happyReduce_344 = happySpecReduce_1  128# happyReduction_344-happyReduction_344 happy_x_1-	 =  case happyOutTok happy_x_1 of { (StringTok happy_var_1) -> -	happyIn133-		 (HsLit (HsString happy_var_1)-	)}--happyReduce_345 = happySpecReduce_1  128# happyReduction_345-happyReduction_345 happy_x_1-	 =  case happyOutTok happy_x_1 of { (UStringTok happy_var_1) -> -	happyIn133-		 (HsLit (HsStringPrim happy_var_1)-	)}--happyReduce_346 = happyMonadReduce 0# 129# happyReduction_346-happyReduction_346 (happyRest) tk-	 = happyThen (( getSrcLoc)-	) (\r -> happyReturn (happyIn134 r))--happyReduce_347 = happySpecReduce_1  130# happyReduction_347-happyReduction_347 happy_x_1-	 =  happyIn135-		 (()-	)--happyReduce_348 = happyMonadReduce 1# 130# happyReduction_348-happyReduction_348 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (( popContext)-	) (\r -> happyReturn (happyIn135 r))--happyReduce_349 = happyMonadReduce 1# 131# happyReduction_349-happyReduction_349 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (( getSrcLoc `thenP` \sl ->-                                 pushCurrentContext)-	) (\r -> happyReturn (happyIn136 r))--happyReduce_350 = happySpecReduce_1  132# happyReduction_350-happyReduction_350 happy_x_1-	 =  case happyOutTok happy_x_1 of { (ConId happy_var_1) -> -	happyIn137-		 (Module happy_var_1-	)}--happyReduce_351 = happySpecReduce_1  132# happyReduction_351-happyReduction_351 happy_x_1-	 =  case happyOutTok happy_x_1 of { (QConId happy_var_1) -> -	happyIn137-		 (Module (fst happy_var_1 ++ "." ++ snd happy_var_1)-	)}--happyReduce_352 = happySpecReduce_1  133# happyReduction_352-happyReduction_352 happy_x_1-	 =  case happyOut125 happy_x_1 of { happy_var_1 -> -	happyIn138-		 (happy_var_1-	)}--happyReduce_353 = happySpecReduce_1  134# happyReduction_353-happyReduction_353 happy_x_1-	 =  case happyOut125 happy_x_1 of { happy_var_1 -> -	happyIn139-		 (happy_var_1-	)}--happyReduce_354 = happySpecReduce_1  135# happyReduction_354-happyReduction_354 happy_x_1-	 =  case happyOut124 happy_x_1 of { happy_var_1 -> -	happyIn140-		 (happy_var_1-	)}--happyReduce_355 = happySpecReduce_1  136# happyReduction_355-happyReduction_355 happy_x_1-	 =  case happyOut124 happy_x_1 of { happy_var_1 -> -	happyIn141-		 (happy_var_1-	)}--happyReduce_356 = happySpecReduce_1  137# happyReduction_356-happyReduction_356 happy_x_1-	 =  case happyOut123 happy_x_1 of { happy_var_1 -> -	happyIn142-		 (happy_var_1-	)}--happyNewToken action sts stk-	= lexer(\tk -> -	let cont i = happyDoAction i tk action sts stk in-	case tk of {-	EOF -> happyDoAction 82# tk action sts stk;-	VarId happy_dollar_dollar -> cont 1#;-	QVarId happy_dollar_dollar -> cont 2#;-	ConId happy_dollar_dollar -> cont 3#;-	QConId happy_dollar_dollar -> cont 4#;-	VarSym happy_dollar_dollar -> cont 5#;-	ConSym happy_dollar_dollar -> cont 6#;-	QVarSym happy_dollar_dollar -> cont 7#;-	QConSym happy_dollar_dollar -> cont 8#;-	IntTok happy_dollar_dollar -> cont 9#;-	UIntTok happy_dollar_dollar -> cont 10#;-	FloatTok happy_dollar_dollar -> cont 11#;-	Character happy_dollar_dollar -> cont 12#;-	UCharacter happy_dollar_dollar -> cont 13#;-	StringTok happy_dollar_dollar -> cont 14#;-	UStringTok happy_dollar_dollar -> cont 15#;-	PragmaOptions happy_dollar_dollar -> cont 16#;-	PragmaStart happy_dollar_dollar -> cont 17#;-	PragmaRules happy_dollar_dollar -> cont 18#;-	PragmaSpecialize happy_dollar_dollar -> cont 19#;-	PragmaEnd -> cont 20#;-	LeftParen -> cont 21#;-	RightParen -> cont 22#;-	LeftUParen -> cont 23#;-	RightUParen -> cont 24#;-	SemiColon -> cont 25#;-	LeftCurly -> cont 26#;-	RightCurly -> cont 27#;-	VRightCurly -> cont 28#;-	LeftSquare -> cont 29#;-	RightSquare -> cont 30#;-	Comma -> cont 31#;-	Underscore -> cont 32#;-	BackQuote -> cont 33#;-	DotDot -> cont 34#;-	DoubleColon -> cont 35#;-	Equals -> cont 36#;-	Backslash -> cont 37#;-	Bar -> cont 38#;-	LeftArrow -> cont 39#;-	RightArrow -> cont 40#;-	At -> cont 41#;-	Tilde -> cont 42#;-	DoubleArrow -> cont 43#;-	Minus -> cont 44#;-	Exclamation -> cont 45#;-	Quest -> cont 46#;-	QuestQuest -> cont 47#;-	StarBang -> cont 48#;-	Star -> cont 49#;-	Hash -> cont 50#;-	Dot -> cont 51#;-	KW_As -> cont 52#;-	KW_Derive -> cont 53#;-	KW_Case -> cont 54#;-	KW_Class -> cont 55#;-	KW_Alias -> cont 56#;-	KW_Data -> cont 57#;-	KW_Default -> cont 58#;-	KW_Deriving -> cont 59#;-	KW_Do -> cont 60#;-	KW_Else -> cont 61#;-	KW_Hiding -> cont 62#;-	KW_If -> cont 63#;-	KW_Import -> cont 64#;-	KW_In -> cont 65#;-	KW_Infix -> cont 66#;-	KW_InfixL -> cont 67#;-	KW_InfixR -> cont 68#;-	KW_Instance -> cont 69#;-	KW_Let -> cont 70#;-	KW_Module -> cont 71#;-	KW_NewType -> cont 72#;-	KW_Of -> cont 73#;-	KW_Then -> cont 74#;-	KW_Type -> cont 75#;-	KW_Where -> cont 76#;-	KW_Qualified -> cont 77#;-	KW_Foreign -> cont 78#;-	KW_Forall -> cont 79#;-	KW_Exists -> cont 80#;-	KW_Kind -> cont 81#;-	_ -> happyError' tk-	})--happyError_ tk = happyError' tk--happyThen :: () => P a -> (a -> P b) -> P b-happyThen = (thenP)-happyReturn :: () => a -> P a-happyReturn = (returnP)-happyThen1 = happyThen-happyReturn1 :: () => a -> P a-happyReturn1 = happyReturn-happyError' :: () => (Token) -> P a-happyError' tk = (\token -> happyError) tk--parse = happySomeParser where-  happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut5 x))--parseHsStmt = happySomeParser where-  happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut97 x))--happySeq = happyDontSeq---{-# NOINLINE parse #-}-{-# NOINLINE parseHsStmt #-}--happyError = parseError "Parse error"-hsSymbol x = HsIdent x-readInteger x = fromIntegral x-readRational x = x--as_name	              = UnQual $ HsIdent "as"-derive_name	      = UnQual $ HsIdent "derive"-qualified_name        = UnQual $ HsIdent "qualified"-hiding_name	      = UnQual $ HsIdent "hiding"-minus_name	      = UnQual $ HsIdent "-"-pling_name	      = UnQual $ HsIdent "!"-star_name	      = UnQual $ HsIdent "*"-hash_name	      = UnQual $ HsIdent "#"-dot_name	      = UnQual $ HsIdent "."-prelude_mod	      = Module "Prelude"-main_mod	      = Module "Main"--unit_con_name	      = UnQual (HsIdent "()")-tuple_con_name i      = Qual (Module "Lhc.Basics") (HsIdent ("("++replicate i ','++")"))--unit_con	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = unit_con_name }-tuple_con i	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = (tuple_con_name i) }---unit_tycon_name       = unit_con_name-fun_tycon_name        = Qual (Module "Lhc.Basics") (HsIdent "->")-list_tycon_name       = UnQual (HsIdent "[]")-tuple_tycon_name i    = tuple_con_name i--list_tycon	      = HsTyCon list_tycon_name-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 28 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Int# Happy_IntList------{-# LINE 49 "templates/GenericTemplate.hs" #-}--{-# LINE 59 "templates/GenericTemplate.hs" #-}--{-# LINE 68 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser).  We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =-	happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = -	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st-	= {- nothing -}---	  case action of-		0#		  -> {- nothing -}-				     happyFail i tk st-		-1# 	  -> {- nothing -}-				     happyAccept i tk st-		n | (n <# (0# :: Int#)) -> {- nothing -}--				     (happyReduceArr ! rule) i tk st-				     where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))-		n		  -> {- nothing -}---				     happyShift new_state i tk st-				     where new_state = (n -# (1# :: Int#))-   where off    = indexShortOffAddr happyActOffsets st-	 off_i  = (off +# i)-	 check  = if (off_i >=# (0# :: Int#))-			then (indexShortOffAddr happyCheck off_i ==#  i)-			else False- 	 action | check     = indexShortOffAddr happyTable off_i-		| otherwise = indexShortOffAddr happyDefActions st--{-# LINE 127 "templates/GenericTemplate.hs" #-}---indexShortOffAddr (HappyA# arr) off =-#if __GLASGOW_HASKELL__ > 500-	narrow16Int# i-#elif __GLASGOW_HASKELL__ == 500-	intToInt16# i-#else-	(i `iShiftL#` 16#) `iShiftRA#` 16#-#endif-  where-#if __GLASGOW_HASKELL__ >= 503-	i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)-#else-	i = word2Int# ((high `shiftL#` 8#) `or#` low)-#endif-	high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-	low  = int2Word# (ord# (indexCharOffAddr# arr off'))-	off' = off *# 2#------data HappyAddr = HappyA# Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 170 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =-     let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in---     trace "shifting the error token" $-     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =-     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk-     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')-     = let r = fn v1 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')-     = let r = fn v1 v2 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')-     = let r = fn v1 v2 v3 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk-     = case happyDrop (k -# (1# :: Int#)) sts of-	 sts1@((HappyCons (st1@(action)) (_))) ->-        	let r = fn stk in  -- it doesn't hurt to always seq here...-       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =-        happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))-       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--happyMonad2Reduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =-       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))-       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--             off    = indexShortOffAddr happyGotoOffsets st1-             off_i  = (off +# nt)-             new_state = indexShortOffAddr happyTable off_i-----happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = -   {- nothing -}-   happyDoAction j tk new_state-   where off    = indexShortOffAddr happyGotoOffsets st-	 off_i  = (off +# nt)- 	 new_state = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail  0# tk old_st _ stk =---	trace "failing" $ -    	happyError_ tk--{-  We don't need state discarding for our restricted implementation of-    "error".  In fact, it can cause some bogus parses, so I've disabled it-    for now --SDM---- discard a state-happyFail  0# tk old_st (HappyCons ((action)) (sts)) -						(saved_tok `HappyStk` _ `HappyStk` stk) =---	trace ("discarding state, depth " ++ show (length stk))  $-	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,---                       save the old token and carry on.-happyFail  i tk (action) sts stk =---      trace "entering error recovery" $-	happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing.  If the --strict flag is given, then Happy emits ---	happySeq = happyDoSeq--- otherwise it emits--- 	happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq   a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template.  GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.
+ lhc-pkg/Main.hs view
@@ -0,0 +1,1357 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2004.+--+-- Package management tool+--+-----------------------------------------------------------------------------++-- TODO:+-- * validate modules+-- * expanding of variables in new-style package conf+-- * version manipulation (checking whether old version exists,+--   hiding old version?)++module Main (main) where++import Paths_lhc+import System.Info+import Data.Version+import Distribution.ModuleName hiding (main)+import Distribution.InstalledPackageInfo hiding (depends)+import Distribution.Compat.ReadP+import Distribution.ParseUtils+import Distribution.Package+import Distribution.Text+import Distribution.Version+import System.FilePath+import System.Cmd       ( rawSystem )+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )++import Prelude++import System.Console.GetOpt+import Text.PrettyPrint+#if __GLASGOW_HASKELL__ >= 609+import qualified Control.Exception as Exception+#else+import qualified Control.Exception.Extensible as Exception+#endif+import Data.Maybe++import Data.Char ( isSpace, toLower )+import Control.Monad+import System.Directory ( doesDirectoryExist, getDirectoryContents,+                          doesFileExist, renameFile, removeFile )+import System.Exit ( exitWith, ExitCode(..) )+import System.Environment ( getArgs, getProgName, getEnv )+import System.IO+import System.IO.Error (try)+import Data.List+import Control.Concurrent++import Foreign+import Foreign.C+#ifdef mingw32_HOST_OS+import GHC.ConsoleHandler+#else+import System.Posix hiding (fdToHandle,version)+#endif++import IO ( isPermissionError )+import System.Posix.Internals+import GHC.Handle (fdToHandle)++#if defined(GLOB)+import System.Process(runInteractiveCommand)+import qualified System.Info(os)+#endif++-- -----------------------------------------------------------------------------+-- Entry point++main :: IO ()+main = do+  args <- getArgs++  case getOpt Permute (flags ++ deprecFlags) args of+        (cli,_,[]) | FlagHelp `elem` cli -> do+           prog <- getProgramName+           bye (usageInfo (usageHeader prog) flags)+        (cli,_,[]) | FlagVersion `elem` cli ->+           bye ourCopyright+        (cli,nonopts,[]) ->+           runit cli nonopts+        (_,_,errors) -> do+           prog <- getProgramName+           die (concat errors ++ usageInfo (usageHeader prog) flags)++-- -----------------------------------------------------------------------------+-- Command-line syntax++data Flag+  = FlagUser+  | FlagGlobal+  | FlagHelp+  | FlagVersion+  | FlagConfig FilePath+  | FlagGlobalConfig FilePath+  | FlagForce+  | FlagForceFiles+  | FlagAutoGHCiLibs+  | FlagSimpleOutput+  | FlagNamesOnly+  | FlagIgnoreCase+  | FlagNoUserDb+  deriving Eq++flags :: [OptDescr Flag]+flags = [+  Option [] ["user"] (NoArg FlagUser)+        "use the current user's package database",+  Option [] ["global"] (NoArg FlagGlobal)+        "use the global package database",+  Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")+        "use the specified package config file",+  Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")+        "location of the global package config",+  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)+        "never read the user package database",+  Option [] ["force"] (NoArg FlagForce)+         "ignore missing dependencies, directories, and libraries",+  Option [] ["force-files"] (NoArg FlagForceFiles)+         "ignore missing directories and libraries only",+  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)+        "automatically build libs for GHCi (with register)",+  Option ['?'] ["help"] (NoArg FlagHelp)+        "display this help and exit",+  Option ['V'] ["version"] (NoArg FlagVersion)+        "output version information and exit",+  Option [] ["simple-output"] (NoArg FlagSimpleOutput)+        "print output in easy-to-parse format for some commands",+  Option [] ["names-only"] (NoArg FlagNamesOnly)+        "only print package names, not versions; can only be used with list --simple-output",+  Option [] ["ignore-case"] (NoArg FlagIgnoreCase)+        "ignore case for substring matching"+  ]++deprecFlags :: [OptDescr Flag]+deprecFlags = [+        -- put deprecated flags here+  ]++ourCopyright :: String+ourCopyright = "LHC package manager version " ++ showVersion version ++ "\n"++usageHeader :: String -> String+usageHeader prog = substProg prog $+  "Usage:\n" +++  "  $p register {filename | -}\n" +++  "    Register the package using the specified installed package\n" +++  "    description. The syntax for the latter is given in the $p\n" +++  "    documentation.\n" +++  "\n" +++  "  $p update {filename | -}\n" +++  "    Register the package, overwriting any other package with the\n" +++  "    same name.\n" +++  "\n" +++  "  $p unregister {pkg-id}\n" +++  "    Unregister the specified package.\n" +++  "\n" +++  "  $p expose {pkg-id}\n" +++  "    Expose the specified package.\n" +++  "\n" +++  "  $p hide {pkg-id}\n" +++  "    Hide the specified package.\n" +++  "\n" +++  "  $p list [pkg]\n" +++  "    List registered packages in the global database, and also the\n" +++  "    user database if --user is given. If a package name is given\n" +++  "    all the registered versions will be listed in ascending order.\n" +++  "    Accepts the --simple-output flag.\n" +++  "\n" +++  "  $p find-module {module}\n" +++  "    List registered packages exposing module {module} in the global\n" +++  "    database, and also the user database if --user is given.\n" +++  "    All the registered versions will be listed in ascending order.\n" +++  "    Accepts the --simple-output flag.\n" +++  "\n" +++  "  $p latest {pkg-id}\n" +++  "    Prints the highest registered version of a package.\n" +++  "\n" +++  "  $p check\n" +++  "    Check the consistency of package depenencies and list broken packages.\n" +++  "    Accepts the --simple-output flag.\n" +++  "\n" +++  "  $p describe {pkg}\n" +++  "    Give the registered description for the specified package. The\n" +++  "    description is returned in precisely the syntax required by $p\n" +++  "    register.\n" +++  "\n" +++  "  $p field {pkg} {field}\n" +++  "    Extract the specified field of the package description for the\n" +++  "    specified package. Accepts comma-separated multiple fields.\n" +++  "\n" +++  "  $p dump\n" +++  "    Dump the registered description for every package.  This is like\n" +++  "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" +++  "    by tools that parse the results, rather than humans.\n" +++  "\n" +++  " Substring matching is supported for {module} in find-module and\n" +++  " for {pkg} in list, describe, and field, where a '*' indicates\n" +++  " open substring ends (prefix*, *suffix, *infix*).\n" +++  "\n" +++  "  When asked to modify a database (register, unregister, update,\n"+++  "  hide, expose, and also check), ghc-pkg modifies the global database by\n"+++  "  default.  Specifying --user causes it to act on the user database,\n"+++  "  or --package-conf can be used to act on another database\n"+++  "  entirely. When multiple of these options are given, the rightmost\n"+++  "  one is used as the database to act upon.\n"+++  "\n"+++  "  Commands that query the package database (list, latest, describe,\n"+++  "  field) operate on the list of databases specified by the flags\n"+++  "  --user, --global, and --package-conf.  If none of these flags are\n"+++  "  given, the default is --global --user.\n"+++  "\n" +++  " The following optional flags are also accepted:\n"++substProg :: String -> String -> String+substProg _ [] = []+substProg prog ('$':'p':xs) = prog ++ substProg prog xs+substProg prog (c:xs) = c : substProg prog xs++-- -----------------------------------------------------------------------------+-- Do the business++data Force = NoForce | ForceFiles | ForceAll | CannotForce+  deriving (Eq,Ord)++data PackageArg = Id PackageIdentifier | Substring String (String->Bool)++runit :: [Flag] -> [String] -> IO ()+runit cli nonopts = do+  installSignalHandlers -- catch ^C and clean up+  prog <- getProgramName+  let+        force+          | FlagForce `elem` cli        = ForceAll+          | FlagForceFiles `elem` cli   = ForceFiles+          | otherwise                   = NoForce+        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli+        splitFields fields = unfoldr splitComma (',':fields)+          where splitComma "" = Nothing+                splitComma fs = Just $ break (==',') (tail fs)++        substringCheck :: String -> Maybe (String -> Bool)+        substringCheck ""    = Nothing+        substringCheck "*"   = Just (const True)+        substringCheck [_]   = Nothing+        substringCheck (h:t) =+          case (h, init t, last t) of+            ('*',s,'*') -> Just (isInfixOf (f s) . f)+            ('*',_, _ ) -> Just (isSuffixOf (f t) . f)+            ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)+            _           -> Nothing+          where f | FlagIgnoreCase `elem` cli = map toLower+                  | otherwise                 = id+#if defined(GLOB)+        glob x | System.Info.os=="mingw32" = do+          -- glob echoes its argument, after win32 filename globbing+          (_,o,_,_) <- runInteractiveCommand ("glob "++x)+          txt <- hGetContents o+          return (read txt)+        glob x | otherwise = return [x]+#endif+  --+  -- first, parse the command+  case nonopts of+#if defined(GLOB)+    -- dummy command to demonstrate usage and permit testing+    -- without messing things up; use glob to selectively enable+    -- windows filename globbing for file parameters+    -- register, update, FlagGlobalConfig, FlagConfig; others?+    ["glob", filename] -> do+        print filename+        glob filename >>= print+#endif+    ["register", filename] ->+        registerPackage filename cli auto_ghci_libs False force+    ["update", filename] ->+        registerPackage filename cli auto_ghci_libs True force+    ["unregister", pkgid_str] -> do+        pkgid <- readGlobPkgId pkgid_str+        unregisterPackage pkgid cli force+    ["expose", pkgid_str] -> do+        pkgid <- readGlobPkgId pkgid_str+        exposePackage pkgid cli force+    ["hide",   pkgid_str] -> do+        pkgid <- readGlobPkgId pkgid_str+        hidePackage pkgid cli force+    ["list"] -> do+        listPackages cli Nothing Nothing+    ["list", pkgid_str] ->+        case substringCheck pkgid_str of+          Nothing -> do pkgid <- readGlobPkgId pkgid_str+                        listPackages cli (Just (Id pkgid)) Nothing+          Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing+    ["find-module", moduleName] -> do+        let match = maybe (==moduleName) id (substringCheck moduleName)+        listPackages cli Nothing (Just match)+    ["latest", pkgid_str] -> do+        pkgid <- readGlobPkgId pkgid_str+        latestPackage cli pkgid+    ["describe", pkgid_str] ->+        case substringCheck pkgid_str of+          Nothing -> do pkgid <- readGlobPkgId pkgid_str+                        describePackage cli (Id pkgid)+          Just m -> describePackage cli (Substring pkgid_str m)+    ["field", pkgid_str, fields] ->+        case substringCheck pkgid_str of+          Nothing -> do pkgid <- readGlobPkgId pkgid_str+                        describeField cli (Id pkgid) (splitFields fields)+          Just m -> describeField cli (Substring pkgid_str m)+                                      (splitFields fields)+    ["check"] -> do+        checkConsistency cli++    ["dump"] -> do+        dumpPackages cli++    [] -> do+        die ("missing command\n" +++                usageInfo (usageHeader prog) flags)+    (_cmd:_) -> do+        die ("command-line syntax error\n" +++                usageInfo (usageHeader prog) flags)++parseCheck :: ReadP a a -> String -> String -> IO a+parseCheck parser str what =+  case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of+    [x] -> return x+    _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)++readGlobPkgId :: String -> IO PackageIdentifier+readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"++parseGlobPackageId :: ReadP r PackageIdentifier+parseGlobPackageId =+  parse+     ++++  (do n <- parse+      string "-*"+      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))++-- globVersion means "all versions"+globVersion :: Version+globVersion = Version{ versionBranch=[], versionTags=["*"] }++-- -----------------------------------------------------------------------------+-- Package databases++-- Some commands operate on a single database:+--      register, unregister, expose, hide+-- however these commands also check the union of the available databases+-- in order to check consistency.  For example, register will check that+-- dependencies exist before registering a package.+--+-- Some commands operate  on multiple databases, with overlapping semantics:+--      list, describe, field++type PackageDBName  = FilePath+type PackageDB      = [InstalledPackageInfo]++type NamedPackageDB = (PackageDBName, PackageDB)+type PackageDBStack = [NamedPackageDB]+        -- A stack of package databases.  Convention: head is the topmost+        -- in the stack.  Earlier entries override later one.++allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]+allPackagesInStack = concatMap snd++getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName)+getPkgDatabases modify my_flags = do+  -- first we determine the location of the global package config.  On Windows,+  -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the+  -- location is passed to the binary using the --global-config flag by the+  -- wrapper script.+  let err_msg = "missing --global-conf option, location of global package.conf unknown\n"+  global_conf <-+     case [ f | FlagGlobalConfig f <- my_flags ] of+        [] -> return Nothing{-do let globalConfPath = "/usr/local/lib/lhc/package.conf"+                  exist <- doesFileExist globalConfPath+                  if exist then return $ Just globalConfPath+                           else return $ Nothing-}+        fs -> return $ Just (last fs)++  let global_conf_dir = fromMaybe "" global_conf ++ ".d"+  global_conf_dir_exists <- doesDirectoryExist global_conf_dir+  global_confs <-+    if global_conf_dir_exists+      then do files <- getDirectoryContents global_conf_dir+              return [ global_conf_dir ++ '/' : file+                     | file <- files+                     , isSuffixOf ".conf" file]+      else return []++  let no_user_db = FlagNoUserDb `elem` my_flags++  -- get the location of the user package database, and create it if necessary+  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)+  appdir <- try $ getAppUserDataDirectory "lhc"++  let targetARCH = arch+      targetOS   = os+  mb_user_conf <-+     if no_user_db then return Nothing else+     case appdir of+       Right dir -> do+               let subdir = targetARCH ++ '-':targetOS ++ '-':showVersion version+                   user_conf = dir </> subdir </> "package.conf"+               user_exists <- doesFileExist user_conf+               return (Just (user_conf,user_exists))+       Left _ ->+               return Nothing++  -- If the user database doesn't exist, and this command isn't a+  -- "modify" command, then we won't attempt to create or use it.+  let sys_databases+        | Just (user_conf,user_exists) <- mb_user_conf,+          modify || user_exists = user_conf : global_confs ++ catMaybes [global_conf]+        | otherwise             = global_confs ++ catMaybes [global_conf]++  e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")+  let env_stack =+        case e_pkg_path of+                Left  _ -> sys_databases+                Right path+                  | last cs == ""  -> init cs ++ sys_databases+                  | otherwise      -> cs+                  where cs = parseSearchPath path++        -- The "global" database is always the one at the bottom of the stack.+        -- This is the database we modify by default.+      virt_global_conf = last env_stack++  let db_flags = [ f | Just f <- map is_db_flag my_flags ]+         where is_db_flag FlagUser+                      | Just (user_conf, _user_exists) <- mb_user_conf+                      = Just user_conf+               is_db_flag FlagGlobal     = Just virt_global_conf+               is_db_flag (FlagConfig f) = Just f+               is_db_flag _              = Nothing++  (final_stack, to_modify) <-+     if not modify+        then    -- For a "read" command, we use all the databases+                -- specified on the command line.  If there are no+                -- command-line flags specifying databases, the default+                -- is to use all the ones we know about.+             if null db_flags then return (env_stack, Nothing)+                              else return (reverse (nub db_flags), Nothing)+        else let+                -- For a "modify" command, treat all the databases as+                -- a stack, where we are modifying the top one, but it+                -- can refer to packages in databases further down the+                -- stack.++                -- -f flags on the command line add to the database+                -- stack, unless any of them are present in the stack+                -- already.+                flag_stack = filter (`notElem` env_stack)+                                [ f | FlagConfig f <- reverse my_flags ]+                                ++ env_stack++                -- the database we actually modify is the one mentioned+                -- rightmost on the command-line.+                to_modify = if null db_flags+                                then Just virt_global_conf+                                else Just (last db_flags)+             in+                return (flag_stack, to_modify)++  db_stack <- mapM (readParseDatabase mb_user_conf) final_stack+  return (db_stack, to_modify)++readParseDatabase :: Maybe (PackageDBName,Bool)+                  -> PackageDBName+                  -> IO (PackageDBName,PackageDB)+readParseDatabase mb_user_conf filename+  -- the user database (only) is allowed to be non-existent+  | Just (user_conf,False) <- mb_user_conf, filename == user_conf+  = return (filename, [])+  | otherwise+  = do str <- readFile filename+       let packages = map convertPackageInfoIn $ read str+       Exception.evaluate packages+         `catchError` \e->+            die ("error while parsing " ++ filename ++ ": " ++ show e)+       return (filename,packages)++-- -----------------------------------------------------------------------------+-- Registering++registerPackage :: FilePath+                -> [Flag]+                -> Bool              -- auto_ghci_libs+                -> Bool              -- update+                -> Force+                -> IO ()+registerPackage input my_flags auto_ghci_libs update force = do+  (db_stack, Just to_modify) <- getPkgDatabases True my_flags+  let+        db_to_operate_on = my_head "register" $+                           filter ((== to_modify).fst) db_stack+  --+  s <-+    case input of+      "-" -> do+        putStr "Reading package info from stdin ... "+        getContents+      f   -> do+        putStr ("Reading package info from " ++ show f ++ " ... ")+        readFile f++  expanded <- expandEnvVars s force++  pkg <- parsePackageInfo expanded+  putStrLn "done."++  let unversioned_deps = filter (not . realVersion) (depends pkg)+  unless (null unversioned_deps) $+      die ("Unversioned dependencies found: " +++           unwords (map display unversioned_deps))++  let truncated_stack = dropWhile ((/= to_modify).fst) db_stack+  -- truncate the stack for validation, because we don't allow+  -- packages lower in the stack to refer to those higher up.+  validatePackageConfig pkg truncated_stack auto_ghci_libs update force+  let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]+      not_this p = package p /= package pkg+  writeNewConfig to_modify new_details++parsePackageInfo+        :: String+        -> IO InstalledPackageInfo+parsePackageInfo str =+  case parseInstalledPackageInfo str of+    ParseOk _warns ok -> return ok+    ParseFailed err -> case locatedErrorMsg err of+                           (Nothing, s) -> die s+                           (Just l, s) -> die (show l ++ ": " ++ s)++-- -----------------------------------------------------------------------------+-- Exposing, Hiding, Unregistering are all similar++exposePackage :: PackageIdentifier ->  [Flag] -> Force -> IO ()+exposePackage = modifyPackage (\p -> [p{exposed=True}])++hidePackage :: PackageIdentifier ->  [Flag] -> Force -> IO ()+hidePackage = modifyPackage (\p -> [p{exposed=False}])++unregisterPackage :: PackageIdentifier ->  [Flag] -> Force -> IO ()+unregisterPackage = modifyPackage (\_ -> [])++modifyPackage+  :: (InstalledPackageInfo -> [InstalledPackageInfo])+  -> PackageIdentifier+  -> [Flag]+  -> Force+  -> IO ()+modifyPackage fn pkgid my_flags force = do+  (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags+  ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)+--  let ((db_name, pkgs) : rest_of_stack) = db_stack+--  ps <- findPackages [(db_name,pkgs)] (Id pkgid)+  let+      pids = map package ps+      modify pkg+          | package pkg `elem` pids = fn pkg+          | otherwise               = [pkg]+      new_config = concat (map modify pkgs)++  let+      old_broken = brokenPackages (allPackagesInStack db_stack)+      rest_of_stack = [ (nm, mypkgs)+                      | (nm, mypkgs) <- db_stack, nm /= db_name ]+      new_stack = (db_name,new_config) : rest_of_stack+      new_broken = map package (brokenPackages (allPackagesInStack new_stack))+      newly_broken = filter (`notElem` map package old_broken) new_broken+  --+  when (not (null newly_broken)) $+      dieOrForceAll force ("unregistering " ++ display pkgid +++           " would break the following packages: "+              ++ unwords (map display newly_broken))++  writeNewConfig db_name new_config++-- -----------------------------------------------------------------------------+-- Listing packages++listPackages ::  [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()+listPackages my_flags mPackageName mModuleName = do+  let simple_output = FlagSimpleOutput `elem` my_flags+  (db_stack, _) <- getPkgDatabases False my_flags+  let db_stack_filtered -- if a package is given, filter out all other packages+        | Just this <- mPackageName =+            map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))+                db_stack+        | Just match <- mModuleName = -- packages which expose mModuleName+            map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))+                db_stack+        | otherwise = db_stack++      db_stack_sorted+          = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]+          where sort_pkgs = sortBy cmpPkgIds+                cmpPkgIds pkg1 pkg2 =+                   case pkgName p1 `compare` pkgName p2 of+                        LT -> LT+                        GT -> GT+                        EQ -> pkgVersion p1 `compare` pkgVersion p2+                   where (p1,p2) = (package pkg1, package pkg2)++      match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)++      pkg_map = allPackagesInStack db_stack+      show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)++  show_func (reverse db_stack_sorted)++  where show_normal pkg_map (db_name,pkg_confs) =+          hPutStrLn stdout (render $+                text db_name <> colon $$ nest 4 packages+                )+           where packages = fsep (punctuate comma (map pp_pkg pkg_confs))+                 broken = map package (brokenPackages pkg_map)+                 pp_pkg p+                   | package p `elem` broken = braces doc+                   | exposed p = doc+                   | otherwise = parens doc+                   where doc = text (display (package p))++        show_simple = simplePackageList my_flags . allPackagesInStack++simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()+simplePackageList my_flags pkgs = do+   let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName+                                                  else display+       strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs+   when (not (null pkgs)) $+      hPutStrLn stdout $ concat $ intersperse " " strs++-- -----------------------------------------------------------------------------+-- Prints the highest (hidden or exposed) version of a package++latestPackage ::  [Flag] -> PackageIdentifier -> IO ()+latestPackage my_flags pkgid = do+  (db_stack, _) <- getPkgDatabases False my_flags+  ps <- findPackages db_stack (Id pkgid)+  show_pkg (sortBy compPkgIdVer (map package ps))+  where+    show_pkg [] = die "no matches"+    show_pkg pids = hPutStrLn stdout (display (last pids))++-- -----------------------------------------------------------------------------+-- Describe++describePackage :: [Flag] -> PackageArg -> IO ()+describePackage my_flags pkgarg = do+  (db_stack, _) <- getPkgDatabases False my_flags+  ps <- findPackages db_stack pkgarg+  doDump ps++dumpPackages :: [Flag] -> IO ()+dumpPackages my_flags = do+  (db_stack, _) <- getPkgDatabases False my_flags+  doDump (allPackagesInStack db_stack)++doDump :: [InstalledPackageInfo] -> IO ()+doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo++-- PackageId is can have globVersion for the version+findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]+findPackages db_stack pkgarg+  = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg++findPackagesByDB :: PackageDBStack -> PackageArg+                 -> IO [(NamedPackageDB, [InstalledPackageInfo])]+findPackagesByDB db_stack pkgarg+  = case [ (db, matched)+         | db@(_, pkgs) <- db_stack,+           let matched = filter (pkgarg `matchesPkg`) pkgs,+           not (null matched) ] of+        [] -> die ("cannot find package " ++ pkg_msg pkgarg)+        ps -> return ps+  where+        pkg_msg (Id pkgid)           = display pkgid+        pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat++matches :: PackageIdentifier -> PackageIdentifier -> Bool+pid `matches` pid'+  = (pkgName pid == pkgName pid')+    && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))++matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool+(Id pid)        `matchesPkg` pkg = pid `matches` package pkg+(Substring _ m) `matchesPkg` pkg = m (display (package pkg))++compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering+compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2++-- -----------------------------------------------------------------------------+-- Field++describeField :: [Flag] -> PackageArg -> [String] -> IO ()+describeField my_flags pkgarg fields = do+  (db_stack, _) <- getPkgDatabases False my_flags+  fns <- toFields fields+  ps <- findPackages db_stack pkgarg+  let top_dir = takeDirectory (fst (last db_stack))+  mapM_ (selectFields fns) (mungePackagePaths top_dir ps)+  where toFields [] = return []+        toFields (f:fs) = case toField f of+            Nothing -> die ("unknown field: " ++ f)+            Just fn -> do fns <- toFields fs+                          return (fn:fns)+        selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns++mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]+-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path+-- with the current topdir (obtained from the -B option).+mungePackagePaths top_dir ps = map munge_pkg ps+  where+  munge_pkg p = p{ importDirs        = munge_paths (importDirs p),+                   includeDirs       = munge_paths (includeDirs p),+                   libraryDirs       = munge_paths (libraryDirs p),+                   frameworkDirs     = munge_paths (frameworkDirs p),+                   haddockInterfaces = munge_paths (haddockInterfaces p),+                   haddockHTMLs      = munge_paths (haddockHTMLs p)+                 }++  munge_paths = map munge_path++  munge_path p+   | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'+   | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'+   | otherwise                               = p++  toHttpPath p = "file:///" ++ p++maybePrefixMatch :: String -> String -> Maybe String+maybePrefixMatch []    rest = Just rest+maybePrefixMatch (_:_) []   = Nothing+maybePrefixMatch (p:pat) (r:rest)+  | p == r    = maybePrefixMatch pat rest+  | otherwise = Nothing++toField :: String -> Maybe (InstalledPackageInfo -> String)+-- backwards compatibility:+toField "import_dirs"     = Just $ strList . importDirs+toField "source_dirs"     = Just $ strList . importDirs+toField "library_dirs"    = Just $ strList . libraryDirs+toField "hs_libraries"    = Just $ strList . hsLibraries+toField "extra_libraries" = Just $ strList . extraLibraries+toField "include_dirs"    = Just $ strList . includeDirs+toField "c_includes"      = Just $ strList . includes+toField "package_deps"    = Just $ strList . map display. depends+toField "extra_cc_opts"   = Just $ strList . ccOptions+toField "extra_ld_opts"   = Just $ strList . ldOptions+toField "framework_dirs"  = Just $ strList . frameworkDirs+toField "extra_frameworks"= Just $ strList . frameworks+toField s                 = showInstalledPackageInfoField s++strList :: [String] -> String+strList = show+++-- -----------------------------------------------------------------------------+-- Check: Check consistency of installed packages++checkConsistency :: [Flag] -> IO ()+checkConsistency my_flags = do+  (db_stack, _) <- getPkgDatabases True my_flags+         -- check behaves like modify for the purposes of deciding which+         -- databases to use, because ordering is important.++  let simple_output = FlagSimpleOutput `elem` my_flags++  let pkgs = allPackagesInStack db_stack++      checkPackage p = do+         (_,es) <- runValidate $ checkPackageConfig p db_stack False True+         if null es+            then return []+            else do+              when (not simple_output) $ do+                  reportError ("There are problems in package " ++ display (package p) ++ ":")+                  reportValidateErrors es "  " Nothing+                  return ()+              return [p]++  broken_pkgs <- concat `fmap` mapM checkPackage pkgs++  let filterOut pkgs1 pkgs2 = filter not_in pkgs2+        where not_in p = package p `notElem` all_ps+              all_ps = map package pkgs1++  let not_broken_pkgs = filterOut broken_pkgs pkgs+      (_, trans_broken_pkgs) = closure [] not_broken_pkgs+      all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs++  when (not (null all_broken_pkgs)) $ do+    if simple_output+      then simplePackageList my_flags all_broken_pkgs+      else do+       reportError ("\nThe following packages are broken, either because they have a problem\n"+++                "listed above, or because they depend on a broken package.")+       mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs++  when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)+++closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]+        -> ([InstalledPackageInfo], [InstalledPackageInfo])+closure pkgs db_stack = go pkgs db_stack+ where+   go avail not_avail =+     case partition (depsAvailable avail) not_avail of+        ([],        not_avail') -> (avail, not_avail')+        (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'++   depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo+                 -> Bool+   depsAvailable pkgs_ok pkg = null dangling+        where dangling = filter (`notElem` pids) (depends pkg)+              pids = map package pkgs_ok++        -- we want mutually recursive groups of package to show up+        -- as broken. (#1750)++brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]+brokenPackages pkgs = snd (closure [] pkgs)++-- -----------------------------------------------------------------------------+-- Manipulating package.conf files++type InstalledPackageInfoString = InstalledPackageInfo_ String++convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString+convertPackageInfoOut+    (pkgconf@(InstalledPackageInfo { exposedModules = e,+                                     hiddenModules = h })) =+        pkgconf{ exposedModules = map display e,+                 hiddenModules  = map display h }++convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo+convertPackageInfoIn+    (pkgconf@(InstalledPackageInfo { exposedModules = e,+                                     hiddenModules = h })) =+        pkgconf{ exposedModules = map convert e,+                 hiddenModules  = map convert h }+    where convert = fromJust . simpleParse++writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()+writeNewConfig filename packages = do+  hPutStr stdout "Writing new package config file... "+  createDirectoryIfMissing True $ takeDirectory filename+  let shown = concat $ intersperse ",\n "+                     $ map (show . convertPackageInfoOut) packages+      fileContents = "[" ++ shown ++ "\n]"+  writeFileAtomic filename fileContents+    `catch` \e ->+      if isPermissionError e+      then die (filename ++ ": you don't have permission to modify this file")+      else ioError e+  hPutStrLn stdout "done."++-----------------------------------------------------------------------------+-- Sanity-check a new package config, and automatically build GHCi libs+-- if requested.++type ValidateError = (Force,String)++newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }++instance Monad Validate where+   return a = V $ return (a, [])+   m >>= k = V $ do+      (a, es) <- runValidate m+      (b, es') <- runValidate (k a)+      return (b,es++es')++verror :: Force -> String -> Validate ()+verror f s = V (return ((),[(f,s)]))++liftIO :: IO a -> Validate a+liftIO k = V (k >>= \a -> return (a,[]))++-- returns False if we should die+reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool+reportValidateErrors es prefix mb_force = do+  oks <- mapM report es+  return (and oks)+  where+    report (f,s)+      | Just force <- mb_force+      = if (force >= f)+           then do reportError (prefix ++ s ++ " (ignoring)")+                   return True+           else if f < CannotForce+                   then do reportError (prefix ++ s ++ " (use --force to override)")+                           return False+                   else do reportError err+                           return False+      | otherwise = do reportError err+                       return False+      where+             err = prefix ++ s++validatePackageConfig :: InstalledPackageInfo+                      -> PackageDBStack+                      -> Bool   -- auto-ghc-libs+                      -> Bool   -- update, or check+                      -> Force+                      -> IO ()+validatePackageConfig pkg db_stack auto_ghci_libs update force = do+  (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update+  ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force)+  when (not ok) $ exitWith (ExitFailure 1)++checkPackageConfig :: InstalledPackageInfo+                      -> PackageDBStack+                      -> Bool   -- auto-ghc-libs+                      -> Bool   -- update, or check+                      -> Validate ()+checkPackageConfig pkg db_stack auto_ghci_libs update = do+  checkPackageId pkg+  checkDuplicates db_stack pkg update+  mapM_ (checkDep db_stack) (depends pkg)+  checkDuplicateDepends (depends pkg)+  mapM_ (checkDir "import-dirs") (importDirs pkg)+  mapM_ (checkDir "library-dirs") (libraryDirs pkg)+  mapM_ (checkDir "include-dirs") (includeDirs pkg)+  checkModules pkg+  mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)+  -- ToDo: check these somehow?+  --    extra_libraries :: [String],+  --    c_includes      :: [String],++-- When the package name and version are put together, sometimes we can+-- end up with a package id that cannot be parsed.  This will lead to+-- difficulties when the user wants to refer to the package later, so+-- we check that the package id can be parsed properly here.+checkPackageId :: InstalledPackageInfo -> Validate ()+checkPackageId ipi =+  let str = display (package ipi) in+  case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of+    [_] -> return ()+    []  -> verror CannotForce ("invalid package identifier: " ++ str)+    _   -> verror CannotForce ("ambiguous package identifier: " ++ str)++checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()+checkDuplicates db_stack pkg update = do+  let+        pkgid = package pkg+        (_top_db_name, pkgs) : _  = db_stack+  --+  -- Check whether this package id already exists in this DB+  --+  when (not update && (pkgid `elem` map package pkgs)) $+       verror CannotForce $+          "package " ++ display pkgid ++ " is already installed"++  let+        uncasep = map toLower . display+        dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)++  when (not update && not (null dups)) $ verror ForceAll $+        "Package names may be treated case-insensitively in the future.\n"+++        "Package " ++ display pkgid +++        " overlaps with: " ++ unwords (map display dups)+++checkDir :: String -> String -> Validate ()+checkDir thisfield d+ | "$topdir"     `isPrefixOf` d = return ()+ | "$httptopdir" `isPrefixOf` d = return ()+        -- can't check these, because we don't know what $(http)topdir is+ | otherwise = do+   there <- liftIO $ doesDirectoryExist d+   when (not there) $+       verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")++checkDep :: PackageDBStack -> PackageIdentifier -> Validate ()+checkDep db_stack pkgid+  | pkgid `elem` pkgids || (not real_version && name_exists) = return ()+  | otherwise = verror ForceAll ("dependency " ++ display pkgid+                                 ++ " doesn't exist")+  where+        -- for backwards compat, we treat 0.0 as a special version,+        -- and don't check that it actually exists.+        real_version = realVersion pkgid++        name_exists = any (\p -> pkgName (package p) == name) all_pkgs+        name = pkgName pkgid++        all_pkgs = allPackagesInStack db_stack+        pkgids = map package all_pkgs++checkDuplicateDepends :: [PackageIdentifier] -> Validate ()+checkDuplicateDepends deps+  | null dups = return ()+  | otherwise = verror ForceAll ("package has duplicate dependencies: " +++                                     unwords (map display dups))+  where+       dups = [ p | (p:_:_) <- group (sort deps) ]++realVersion :: PackageIdentifier -> Bool+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []++checkHSLib :: [String] -> Bool -> String -> Validate ()+checkHSLib dirs auto_ghci_libs lib = do+  let batch_lib_file = "lib" ++ lib ++ ".a"+  m <- liftIO $ doesFileExistOnPath batch_lib_file dirs+  case m of+    Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file +++                                   " on library path")+    Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs++doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)+doesFileExistOnPath file path = go path+  where go []     = return Nothing+        go (p:ps) = do b <- doesFileExistIn file p+                       if b then return (Just p) else go ps++doesFileExistIn :: String -> String -> IO Bool+doesFileExistIn lib d+ | "$topdir"     `isPrefixOf` d = return True+ | "$httptopdir" `isPrefixOf` d = return True+ | otherwise                = doesFileExist (d </> lib)++checkModules :: InstalledPackageInfo -> Validate ()+checkModules pkg = do+  mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)+  where+    findModule modl = do+      -- there's no .hi file for GHC.Prim+      if components modl == ["GHC", "Prim"] then return () else do+      let file = toFilePath modl <.> "hi"+      m <- liftIO $ doesFileExistOnPath file (importDirs pkg)+      when (isNothing m) $+         verror ForceFiles ("file " ++ file ++ " is missing")++checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()+checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build+  | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file+  | otherwise  = do+      m <- doesFileExistOnPath ghci_lib_file dirs+      when (isNothing m) $+        hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)+ where+    ghci_lib_file = lib <.> "o"++-- automatically build the GHCi version of a batch lib,+-- using ld --whole-archive.++autoBuildGHCiLib :: String -> String -> String -> IO ()+autoBuildGHCiLib dir batch_file ghci_file = do+  let ghci_lib_file  = dir ++ '/':ghci_file+      batch_lib_file = dir ++ '/':batch_file+  hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")+#if defined(darwin_HOST_OS)+  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]+#elif defined(mingw32_HOST_OS)+  execDir <- getExecDir "/bin/ghc-pkg.exe"+  r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]+#else+  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]+#endif+  when (r /= ExitSuccess) $ exitWith r+  hPutStrLn stderr (" done.")++-- -----------------------------------------------------------------------------+-- Searching for modules++#if not_yet++findModules :: [FilePath] -> IO [String]+findModules paths =+  mms <- mapM searchDir paths+  return (concat mms)++searchDir path prefix = do+  fs <- getDirectoryEntries path `catch` \_ -> return []+  searchEntries path prefix fs++searchEntries path prefix [] = return []+searchEntries path prefix (f:fs)+  | looks_like_a_module  =  do+        ms <- searchEntries path prefix fs+        return (prefix `joinModule` f : ms)+  | looks_like_a_component  =  do+        ms <- searchDir (path </> f) (prefix `joinModule` f)+        ms' <- searchEntries path prefix fs+        return (ms ++ ms')+  | otherwise+        searchEntries path prefix fs++  where+        (base,suffix) = splitFileExt f+        looks_like_a_module =+                suffix `elem` haskell_suffixes &&+                all okInModuleName base+        looks_like_a_component =+                null suffix && all okInModuleName base++okInModuleName c++#endif++-- ---------------------------------------------------------------------------+-- expanding environment variables in the package configuration++expandEnvVars :: String -> Force -> IO String+expandEnvVars str0 force = go str0 ""+ where+   go "" acc = return $! reverse acc+   go ('$':'{':str) acc | (var, '}':rest) <- break close str+        = do value <- lookupEnvVar var+             go rest (reverse value ++ acc)+        where close c = c == '}' || c == '\n' -- don't span newlines+   go (c:str) acc+        = go str (c:acc)++   lookupEnvVar :: String -> IO String+   lookupEnvVar nm =+        catch (System.Environment.getEnv nm)+           (\ _ -> do dieOrForceAll force ("Unable to expand variable " +++                                        show nm)+                      return "")++-----------------------------------------------------------------------------++getProgramName :: IO String+getProgramName = liftM (`withoutSuffix` ".bin") getProgName+   where str `withoutSuffix` suff+            | suff `isSuffixOf` str = take (length str - length suff) str+            | otherwise             = str++bye :: String -> IO a+bye s = putStr s >> exitWith ExitSuccess++die :: String -> IO a+die = dieWith 1++dieWith :: Int -> String -> IO a+dieWith ec s = do+  hFlush stdout+  prog <- getProgramName+  hPutStrLn stderr (prog ++ ": " ++ s)+  exitWith (ExitFailure ec)++dieOrForceAll :: Force -> String -> IO ()+dieOrForceAll ForceAll s = ignoreError s+dieOrForceAll _other s   = dieForcible s++ignoreError :: String -> IO ()+ignoreError s = reportError (s ++ " (ignoring)")++reportError :: String -> IO ()+reportError s = do hFlush stdout; hPutStrLn stderr s++dieForcible :: String -> IO ()+dieForcible s = die (s ++ " (use --force to override)")++my_head :: String -> [a] -> a+my_head s []      = error s+my_head _ (x : _) = x++-----------------------------------------+-- Cut and pasted from ghc/compiler/main/SysTools++#if defined(mingw32_HOST_OS)+subst :: Char -> Char -> String -> String+subst a b ls = map (\ x -> if x == a then b else x) ls++unDosifyPath :: FilePath -> FilePath+unDosifyPath xs = subst '\\' '/' xs++getExecDir :: String -> IO (Maybe String)+-- (getExecDir cmd) returns the directory in which the current+--                  executable, which should be called 'cmd', is running+-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,+-- you'll get "/a/b/c" back as the result+getExecDir cmd+  = allocaArray len $ \buf -> do+        ret <- getModuleFileName nullPtr buf len+        if ret == 0 then return Nothing+                    else do s <- peekCString buf+                            return (Just (reverse (drop (length cmd)+                                                        (reverse (unDosifyPath s)))))+  where+    len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.++foreign import stdcall unsafe  "GetModuleFileNameA"+  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32+#else+getExecDir :: String -> IO (Maybe String)+getExecDir _ = return Nothing+#endif++-----------------------------------------+-- Adapted from ghc/compiler/utils/Panic++installSignalHandlers :: IO ()+installSignalHandlers = do+  threadid <- myThreadId+  let+      interrupt = Exception.throwTo threadid+                                    (Exception.ErrorCall "interrupted")+  --+#if !defined(mingw32_HOST_OS)+  installHandler sigQUIT (Catch interrupt) Nothing+  installHandler sigINT  (Catch interrupt) Nothing+  return ()+#elif __GLASGOW_HASKELL__ >= 603+  -- GHC 6.3+ has support for console events on Windows+  -- NOTE: running GHCi under a bash shell for some reason requires+  -- you to press Ctrl-Break rather than Ctrl-C to provoke+  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know+  -- why --SDM 17/12/2004+  let sig_handler ControlC = interrupt+      sig_handler Break    = interrupt+      sig_handler _        = return ()++  installHandler (Catch sig_handler)+  return ()+#else+  return () -- nothing+#endif++#if __GLASGOW_HASKELL__ <= 604+isInfixOf               :: (Eq a) => [a] -> [a] -> Bool+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)+#endif++#if mingw32_HOST_OS || mingw32_TARGET_OS+throwIOIO :: Exception.IOException -> IO a+throwIOIO = Exception.throwIO++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+catchIO = Exception.catch+#endif++catchError :: IO a -> (String -> IO a) -> IO a+catchError io handler = io `Exception.catch` handler'+    where handler' (Exception.ErrorCall err) = handler err+++-- copied from Cabal's Distribution.Simple.Utils, except that we want+-- to use text files here, rather than binary files.+writeFileAtomic :: FilePath -> String -> IO ()+writeFileAtomic targetFile content = do+  (newFile, newHandle) <- openNewFile targetDir template+  do  hPutStr newHandle content+      hClose newHandle+#if mingw32_HOST_OS || mingw32_TARGET_OS+      renameFile newFile targetFile+        -- If the targetFile exists then renameFile will fail+        `catchIO` \err -> do+          exists <- doesFileExist targetFile+          if exists+            then do removeFile targetFile+                    -- Big fat hairy race condition+                    renameFile newFile targetFile+                    -- If the removeFile succeeds and the renameFile fails+                    -- then we've lost the atomic property.+            else throwIOIO err+#else+      renameFile newFile targetFile+#endif+   `Exception.onException` do hClose newHandle+                              removeFile newFile+  where+    template = targetName <.> "tmp"+    targetDir | null targetDir_ = "."+              | otherwise       = targetDir_+    --TODO: remove this when takeDirectory/splitFileName is fixed+    --      to always return a valid dir+    (targetDir_,targetName) = splitFileName targetFile++-- Ugh, this is a copy/paste of code from the base library, but+-- if uses 666 rather than 600 for the permissions.+openNewFile :: FilePath -> String -> IO (FilePath, Handle)+openNewFile dir template = do+  pid <- c_getpid+  findTempName pid+  where+    -- We split off the last extension, so we can use .foo.ext files+    -- for temporary files (hidden on Unix OSes). Unfortunately we're+    -- below filepath in the hierarchy here.+    (prefix,suffix) =+       case break (== '.') $ reverse template of+         -- First case: template contains no '.'s. Just re-reverse it.+         (rev_suffix, "")       -> (reverse rev_suffix, "")+         -- Second case: template contains at least one '.'. Strip the+         -- dot from the prefix and prepend it to the suffix (if we don't+         -- do this, the unique number will get added after the '.' and+         -- thus be part of the extension, which is wrong.)+         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)+         -- Otherwise, something is wrong, because (break (== '.')) should+         -- always return a pair with either the empty string or a string+         -- beginning with '.' as the second component.+         _                      -> error "bug in System.IO.openTempFile"++    oflags = rw_flags .|. o_EXCL++    findTempName x = do+      fd <- withCString filepath $ \ f ->+              c_open f oflags 0o666+      if fd < 0+       then do+         errno <- getErrno+         if errno == eEXIST+           then findTempName (x+1)+           else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))+       else do+         -- XXX We want to tell fdToHandle what the filepath is,+         -- as any exceptions etc will only be able to report the+         -- fd currently+         h <-+#if __GLASGOW_HASKELL__ >= 609+              fdToHandle fd+#else+              fdToHandle (fromIntegral fd)+#endif+              `Exception.onException` c_close fd+         return (filepath, h)+      where+        filename        = prefix ++ show x ++ suffix+        filepath        = dir `combine` filename++-- XXX Copied from GHC.Handle+std_flags, output_flags, rw_flags :: CInt+std_flags    = o_NONBLOCK   .|. o_NOCTTY+output_flags = std_flags    .|. o_CREAT+rw_flags     = output_flags .|. o_RDWR++-- | The function splits the given string to substrings+-- using 'isSearchPathSeparator'.+parseSearchPath :: String -> [FilePath]+parseSearchPath path = split path+  where+    split :: String -> [String]+    split s =+      case rest' of+        []     -> [chunk]+        _:rest -> chunk : split rest+      where+        chunk =+          case chunk' of+#ifdef mingw32_HOST_OS+            ('\"':xs@(_:_)) | last xs == '\"' -> init xs+#endif+            _                                 -> chunk'++        (chunk', rest') = break isSearchPathSeparator s
lhc-regress/Main.hs view
@@ -11,10 +11,9 @@ import System.Exit import System.Directory import Control.Monad-import Control.Exception+import Control.Exception.Extensible import System.Timeout import Control.Concurrent-import Control.Exception import Text.Printf import qualified Data.ByteString.Char8 as B @@ -119,18 +118,18 @@ runTestCase cfg tc   = bracket (createDirectoryIfMissing True testDir)             (\_ -> removeDirectoryRecursive testDir) $ \_ -> checkFail $ withTimeout $-    do let args = [ "-o", progName-                  , "--ho-dir", testDir-                  , "-flint"-                  , testCasePath tc ] ++-                  cfgLHCOptions cfg-       when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (cfgLHCPath cfg:args)-       (ret,out,err) <- execProcess (cfgLHCPath cfg) args B.empty+    do let args = [ "eval"+                  , testCasePath tc `replaceExtension` "hcr" ] +++                  cfgLHCOptions cfg +++                  testCaseArgs tc+           ghcArgs = ["-fforce-recomp","-fext-core","-O2","-c",testCasePath tc]+       when (cfgVerbose cfg >= 4) $ putStrLn $ unwords ("ghc":ghcArgs)+       (ret,out,err) <- execProcess "lhc" ghcArgs B.empty        case ret of-         ExitFailure c -> return $ CompileError $ unlines $ ["lhc failed with: " ++ show c, B.unpack err]+         ExitFailure c -> return $ CompileError $ unlines $ ["ghc failed with: " ++ show c, B.unpack err]          ExitSuccess-           -> do when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (progName:testCaseArgs tc)-                 (ret,out,err) <- execProcess progName (testCaseArgs tc) (testCaseStdin tc)+           -> do when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (cfgLHCPath cfg:args)+                 (ret,out,err) <- execProcess (cfgLHCPath cfg) args B.empty                  case (testCaseStdout tc, testCaseStderr tc) of                    (Just expectedOut,_) | expectedOut /= out -> return $ ProgramError "Unexpected stdout" $ B.unpack out                    (_,Just expectedErr) | expectedErr /= err -> return $ ProgramError "Unexpected stderr" $ B.unpack err@@ -154,11 +153,7 @@ execProcess cmd args input = do   (inh, outh, errh, pid) <- runInteractiveProcess cmd args Nothing Nothing   handle (\e -> do terminateProcess pid-#if BASE4                    throw (e::SomeException)) $ do-#else-                   throw e) $ do-#endif   outVar <- newEmptyMVar   forkIO $ B.hGetContents outh >>= putMVar outVar   errVar <- newEmptyMVar
+ lhc-regress/Setup.hs view
@@ -0,0 +1,111 @@+module Setup+  ( Config(..)+  , parseArguments+  ) where++import System.Exit+import System.Environment+import System.Console.GetOpt+import System.Directory+import Data.Maybe+import Data.Char++data Config =+  Config { cfgShowMarginalCoverage :: Bool+         , cfgVerbose              :: Int+         , cfgThreads              :: Int+         , cfgTimeLimit            :: Maybe Int+         , cfgTempDir              :: FilePath+         , cfgLHCPath              :: FilePath+         , cfgLHCOptions           :: [String]+         , cfgTestTimeout          :: Int -- in seconds+         , cfgComplete             :: Bool+         } deriving Show+++emptyConfig :: IO Config+emptyConfig = do tmp <- getTemporaryDirectory+                 lhc <- findExecutable "lhc"+                 return Config { cfgShowMarginalCoverage = False+                               , cfgVerbose = 1+                               , cfgThreads = 1+                               , cfgTimeLimit = Nothing+                               , cfgTempDir = tmp+                               , cfgLHCPath = fromMaybe "lhc" lhc+                               , cfgLHCOptions = ["+RTS","-M1G","-RTS"]+                               , cfgTestTimeout = 60+                               , cfgComplete = False}++cmd_verbose :: OptDescr (Config -> Config)+cmd_verbose = Option "v" ["verbose"] (OptArg verboseFlag "n")+              "Control verbosity (n is 0-5, normal verbosity level is 1, -v alone is equivalent to -v3)"+  where+    verboseFlag mb_s cfg = cfg{cfgVerbose = (maybe 3 read mb_s)}++cmd_threads :: OptDescr (Config -> Config)+cmd_threads = Option "N" ["threads"] (ReqArg threadsFlag "n")+              "Use <n> OS threads (default: 1)"+  where+    threadsFlag s cfg = cfg{cfgThreads = read s }++cmd_options :: OptDescr (Config -> Config)+cmd_options = Option "" ["lhc-options"] (ReqArg optionsFlag "OPTS")+              "Give extra options to lhc"+  where+    optionsFlag s cfg = cfg{cfgLHCOptions = cfgLHCOptions cfg ++ words s}++cmd_complete :: OptDescr (Config -> Config)+cmd_complete = Option "c" ["complete"] (OptArg completeFlag "BOOL")+              "Run all tests even if some fail."+  where+    completeFlag mb_s cfg = cfg{cfgComplete = maybe True (parseBool . map toLower) mb_s}++cmd_with_lhc :: OptDescr (Config -> Config)+cmd_with_lhc = Option "" ["with-lhc"] (ReqArg (\path cfg -> cfg{cfgLHCPath = path}) "PATH")+               "Give the path to lhc."++{-+cmd_dryrun :: OptDescr Flag+cmd_dryrun = Option "d" ["dry-run"] (OptArg dryrunFlag "bool")+              "Dry run. Accept values in the line of 'false', '0' and 'no'. Default: false."+  where+    dryrunFlag mb_s = DryRun (maybe True (parse.map toLower) mb_s)-}++parseBool "false" = False+parseBool "0" = False+parseBool "no" = False+parseBool _ = True+++globalOptions :: [OptDescr (Config -> Config)]+globalOptions =+    [-- cmd_help+      cmd_verbose+    , cmd_threads+    , cmd_options+    , cmd_complete+    , cmd_with_lhc+--    , cmd_dryrun+    ]+++printUsage =+    do pname <- getProgName+       let syntax_line = concat [ "Usage: ", pname+                                , " [FLAGS] [PATH]"+                                , "\n\nGlobal flags:"]+       putStrLn (usageInfo syntax_line globalOptions)+  where align n str = str ++ replicate (n - length str) ' '++parseArguments :: [String] -> IO (Config, [FilePath])+parseArguments args+  = case getOpt' Permute globalOptions args of+      (flags,paths,[],[]) ->+         do cfg <- emptyConfig+            return (foldr (.) id flags cfg, if null paths then ["."] else paths)+      (flags,paths,warns,[]) ->+         do printUsage+            exitWith ExitSuccess+      (_,_,_,errs) ->+         do putStrLn $ "Errors: \n" ++ unlines errs+            exitFailure
+ lhc-regress/TestCase.hs view
@@ -0,0 +1,76 @@+module TestCase where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B++import System.Directory+import System.FilePath+import Control.Monad++{-++A testcase is any Haskell file (.hs or .lhs) that has an associated+.expected.stdout or .expected.stderr file.++-}++data TestCase = TestCase { testCasePath     :: String+                         , testCaseStdin    :: ByteString+                         , testCaseStdout   :: Maybe ByteString+                         , testCaseStderr   :: Maybe ByteString+                         , testCaseArgs     :: [String]+                         , testCaseMustFail :: Bool+                         } deriving Show+++findTestCases :: FilePath -> IO [TestCase]+findTestCases root+  = do contents <- getDirectoryContents root+       let walker acc [] = return acc+           walker acc (c:cs) | c `elem` [".",".."] = walker acc cs+           walker acc (c:cs)+             = do isDir <- doesDirectoryExist (root </> c)+                  if isDir+                     then do --putStrLn $ "Recursing: " ++ root </> c+                             sub <- findTestCases (root </> c)+                             walker (sub++acc) cs+                     else do --putStrLn $ "Looking at: " ++ root </> c+                             mbTest <- getTestCase (root </> c)+                             case mbTest of+                               Nothing   -> walker acc cs+                               Just test -> walker (test:acc) cs+       walker [] contents+++getTestCase :: FilePath -> IO (Maybe TestCase)+getTestCase path | takeExtension path `elem` [".hs",".lhs"]+  = do isValid <- liftM2 (||) (doesFileExist stdoutFile)+                              (doesFileExist stderrFile)+       if isValid+          then do stdin  <- B.readFile stdinFile `orElse` return B.empty+                  stdout <- fmap Just (B.readFile stdoutFile) `orElse` return Nothing+                  stderr <- fmap Just (B.readFile stderrFile) `orElse` return Nothing+                  args <- fmap words (readFile argsFile) `orElse` return [] -- FIXME: Use unlines?+                  mustFail <- doesFileExist mustFailFile+                  return $ Just TestCase { testCasePath     = path+                                         , testCaseStdin    = stdin+                                         , testCaseStdout   = stdout+                                         , testCaseStderr   = stderr+                                         , testCaseArgs     = args+                                         , testCaseMustFail = mustFail }+          else return Nothing+  where root = takeDirectory path+        name = dropExtension (takeFileName path)+        stdinFile = root </> name <.> "stdin"+        stdoutFile = root </> name <.> "expected.stdout"+        stderrFile = root </> name <.> "expected.stderr"+        argsFile = root </> name <.> "args"+        mustFailFile = root </> name <.> "mustfail"+getTestCase _ = return Nothing++testCaseRoot = takeDirectory . testCasePath+testCaseName = dropExtension . takeFileName . testCasePath++a `orElse` b = a `catch` \_e -> b++
lhc.cabal view
@@ -1,113 +1,160 @@ cabal-version:       >= 1.6 name:                lhc-version:             0.6.20090126+version:             0.8 synopsis:            LHC Haskell Compiler description:   lhc is a haskell compiler which aims to produce the most efficient programs possible via whole   program analysis and other optimizations.-Tested-With:         GHC == 6.10.1, GHC == 6.8.3+Tested-With:         GHC == 6.10.1 category:            Compiler-license:             GPL-license-file:        COPYING-author:              John Meacham, David Himmelstrup+license:             PublicDomain+author:              David Himmelstrup maintainer:          lhc@projects.haskell.org homepage:            http://lhc.seize.it/ build-type:          Custom-Extra-Source-Files:  src/arch/generic.arch, src/arch/i686.arch, src/arch/x86_64.arch-extra-source-files:  lib/base/base.cabal,-                     lib/base/Setup.hs,-                     lib/base/src/Control/*.hs,-                     lib/base/src/Control/Monad/*.hs,-                     lib/base/src/Data/Array/*.hs,-                     lib/base/src/Data/*.hs,-                     lib/base/src/Debug/*.hs,-                     lib/base/src/Foreign/C/*.hs,-                     lib/base/src/Foreign/Marshal/*.hs,-                     lib/base/src/Foreign/*.hs,-                     lib/base/src/Foreign/Storable.m4,-                     lib/base/src/Lhc/*.hs-                     lib/base/src/Lhc/Inst/*.hs,-                     lib/base/src/Lhc/Inst/Num.m4-                     lib/base/src/Lhc/Order.m4,-                     lib/base/src/Lhc/Text/*.hs,-                     lib/base/src/Prelude/*.hs,-                     lib/base/src/Prelude.hs,-                     lib/base/src/System/Console/GetOpt.hs,-                     lib/base/src/System/IO/*.hs,-                     lib/base/src/System/*.hs,-                     lib/base/src/*.hs,-                     lib/base/src/Text/*.hs,-                     lib/base/src/Text/Show/*.hs,-                     lib/base/src/Unsafe/*.hs-data-dir:            data-data-files:          HsFFI.h names.txt operators.txt prelude.m4 primitives.txt props.txt wsize.h -                     rts/lhc_rts.c rts/lhc_rts2.c rts/lhc_rts_alloc.c rts/lhc_rts_header.h -                     -flag base4+data-files:+  lib/base/base.cabal+  lib/base/includes/CTypes.h+  lib/base/includes/ieee-flpt.h+  lib/base/includes/Typeable.h+  lib/base/LICENSE+  lib/base/Setup.lhs+  lib/base/src/Control/Exception/Base.hs+  lib/base/src/Control/Exception.hs+  lib/base/src/Control/Monad.hs+  lib/base/src/Data/Bits.hs+  lib/base/src/Data/Char.hs+  lib/base/src/Data/Dynamic.hs+  lib/base/src/Data/Either.hs+  lib/base/src/Data/HashTable.hs+  lib/base/src/Data/Int.hs+  lib/base/src/Data/IORef.hs+  lib/base/src/Data/Ix.hs+  lib/base/src/Data/List.hs+  lib/base/src/Data/Maybe.hs+  lib/base/src/Data/Tuple.hs+  lib/base/src/Data/Typeable.hs+  lib/base/src/Data/Typeable.hs-boot+  lib/base/src/Data/Word.hs+  lib/base/src/Foreign/C/Error.hsc+  lib/base/src/Foreign/C/String.hs+  lib/base/src/Foreign/C/Types.hs+  lib/base/src/Foreign/C.hs+  lib/base/src/Foreign/ForeignPtr.hs+  lib/base/src/Foreign/Marshal/Alloc.hs+  lib/base/src/Foreign/Marshal/Array.hs+  lib/base/src/Foreign/Marshal/Error.hs+  lib/base/src/Foreign/Marshal/Pool.hs+  lib/base/src/Foreign/Marshal/Utils.hs+  lib/base/src/Foreign/Marshal.hs+  lib/base/src/Foreign/Ptr.hs+  lib/base/src/Foreign/StablePtr.hs+  lib/base/src/Foreign/Storable.hs+  lib/base/src/Foreign/Storable.hs-boot+  lib/base/src/Foreign.hs+  lib/base/src/GHC/Arr.lhs+  lib/base/src/GHC/Base.lhs+  lib/base/src/GHC/Classes.hs+  lib/base/src/GHC/Conc.lhs+  lib/base/src/GHC/Enum.lhs+  lib/base/src/GHC/Err.lhs+  lib/base/src/GHC/Err.lhs-boot+  lib/base/src/GHC/Exception.lhs+  lib/base/src/GHC/Float.lhs+  lib/base/src/GHC/ForeignPtr.hs+  lib/base/src/GHC/Handle.hs+  lib/base/src/GHC/Handle.hs-boot+  lib/base/src/GHC/Int.hs+  lib/base/src/GHC/IO.hs+  lib/base/src/GHC/IOBase.lhs+  lib/base/src/GHC/List.lhs+  lib/base/src/GHC/Num.lhs+  lib/base/src/GHC/Pack.lhs+  lib/base/src/GHC/Ptr.lhs+  lib/base/src/GHC/Read.lhs+  lib/base/src/GHC/Real.lhs+  lib/base/src/GHC/Show.lhs+  lib/base/src/GHC/ST.lhs+  lib/base/src/GHC/Stable.lhs+  lib/base/src/GHC/Storable.lhs+  lib/base/src/GHC/STRef.lhs+  lib/base/src/GHC/TopHandler.lhs+  lib/base/src/GHC/Unicode.hs+  lib/base/src/GHC/Unicode.hs-boot+  lib/base/src/GHC/Word.hs+  lib/base/src/Numeric.hs+  lib/base/src/Prelude.hs+  lib/base/src/Prelude.hs-boot+  lib/base/src/System/Environment.hs+  lib/base/src/System/IO/Error.hs+  lib/base/src/System/IO/Unsafe.hs+  lib/base/src/System/IO.hs+  lib/base/src/System/Posix/Internals.hs+  lib/base/src/System/Posix/Types.hs+  lib/base/src/Text/ParserCombinators/ReadP.hs+  lib/base/src/Text/ParserCombinators/ReadPrec.hs+  lib/base/src/Text/Printf.hs+  lib/base/src/Text/Read/Lex.hs+  lib/base/src/Text/Read.hs+  lib/base/src/Text/Show/Functions.hs+  lib/base/src/Text/Show.hs+  lib/base/src/Unsafe/Coerce.hs+  lib/ghc-prim/cbits/longlong.c+  lib/ghc-prim/GHC/Bool.hs+  lib/ghc-prim/GHC/Generics.hs+  lib/ghc-prim/GHC/IntWord32.hs+  lib/ghc-prim/GHC/IntWord64.hs+  lib/ghc-prim/GHC/Ordering.hs+  lib/ghc-prim/GHC/Prim.hs+  lib/ghc-prim/GHC/PrimopWrappers.hs+  lib/ghc-prim/GHC/Tuple.hs+  lib/ghc-prim/GHC/Types.hs+  lib/ghc-prim/GHC/Unit.hs+  lib/ghc-prim/ghc-prim.cabal+  lib/ghc-prim/LICENSE+  lib/ghc-prim/Setup.hs+  lib/integer-native/integer.cabal+  lib/integer-native/LICENSE+  lib/integer-native/Setup.lhs+  lib/integer-native/src/GHC/Integer/Internals.hs+  lib/integer-native/src/GHC/Integer.hs+++flag hpc+  default:            False flag threaded   default:            False flag lhc-regress   default:            False-flag with-base++flag with-libs   default:            False  Executable lhc- main-is:             Main.hs- Hs-Source-Dirs:      src- cc-Options:          -std=c99 -O2 -Wall- ghc-prof-options:    -auto-all- Extensions:          DeriveDataTypeable, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving-                      MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts-                      UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, ParallelListComp,-                      OverlappingInstances, RecursiveDo, GADTs, RankNTypes, PatternGuards, TemplateHaskell- build-depends:       containers, mtl, pretty, array, bytestring, pureMD5,-                      binary >= 0.4.4, directory, random, regex-compat,-                      graphviz, fgl, unix, zlib, old-time, haskell98,-                      utf8-string, stringtable-atom, derive >= 0.1.4,-                      filepath, ansi-wl-pprint >= 0.5.0, ansi-terminal >= 0.5.0-                      - ghc-options:         -fwarn-unused-imports- if flag(base4)-  build-depends:      base >= 4 && < 5, syb-  cpp-options:        -DBASE4+ main-is:            GhcMain.hs+ Hs-Source-Dirs:     src+ ghc-prof-options:   -auto-all+ build-depends:      base >= 4 && < 5, mtl, bytestring, containers, ansi-wl-pprint, binary,+                     digest, bytestring-trie, core >=0.5, filepath, directory,+                     derive, unix, libffi, xhtml, pretty, ghc >= 6.10++ other-modules:      Paths_lhc, LhcMain, CompactString, Traverse, Setup,+                     Grin.Eval.Compile, Grin.Eval.Methods, Grin.Eval.Primitives,+                     Grin.Eval.Types, Grin.FromCore, Grin.HPT.Environment,+                     Grin.HPT.Lower, Grin.HPT.Solve, Grin.HPT,+                     Grin.HtmlAnnotate, Grin.Lowering.Apply,+                     Grin.Lowering.GHCism, Grin.Optimize.Simple, Grin.Pretty,+                     Grin.SimpleCore.DeadCode, Grin.SimpleCore.Types,+                     Grin.SimpleCore, Grin.Types++ ghc-options:        -fwarn-unused-imports -fwarn-unused-binds -fwarn-incomplete-patterns+ Extensions:         ScopedTypeVariables+ if flag(with-libs)+   x-build-libs:     True  else-  build-depends:      base >= 3 && < 4-  Extensions:         PatternSignatures+   x-build-libs:     False  if flag(threaded)-  ghc-options:        -threaded- if flag(with-base)-  x-build-base:       True- else-  x-build-base:       False- Other-modules:-  CharIO, FindFixpoint, FlagOpts, Options, PrimitiveOperators,-  DataConstructors, FlagDump, GenUtil, PackedString, RawFiles, Stats,-  C.FromGrin2 C.Arch C.FFI C.Generate C.Prims Cmm.Op-  Cmm.OpEval Cmm.Number-  DerivingDrift.RuleUtils DerivingDrift.DataP DerivingDrift.Drift DerivingDrift.StandardRules-  Doc.DocLike Doc.PPrint Doc.Pretty Doc.Chars Doc.Attr E.TypeAnalysis 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.PrimOpt E.Program E.Rules E.SSimplify E.SStrictness E.Show E.Subst E.ToHs-  E.Traverse E.Type E.WorkerWrapper E.TypeCheck E.Values Fixer.Fixer Fixer.Supply Fixer.VMap-  FrontEnd.FrontEnd FrontEnd.Class FrontEnd.Desugar FrontEnd.DataConsAssump FrontEnd.DeclsDepends-  FrontEnd.DependAnalysis FrontEnd.Exports FrontEnd.Diagnostic FrontEnd.HsErrors FrontEnd.HsPretty-  FrontEnd.HsSyn FrontEnd.Infix FrontEnd.KindInfer FrontEnd.Lexer FrontEnd.ParseMonad-  FrontEnd.ParseUtils FrontEnd.Syn.Traverse FrontEnd.Syn.Options FrontEnd.Rename FrontEnd.SrcLoc-  FrontEnd.Representation FrontEnd.Tc.Class FrontEnd.Tc.Kind FrontEnd.Tc.Main FrontEnd.Tc.Module-  FrontEnd.Tc.Monad FrontEnd.Tc.Type FrontEnd.Tc.Unify FrontEnd.TypeSynonyms FrontEnd.TypeSigs-  FrontEnd.HsParser FrontEnd.TypeSyns FrontEnd.Unlit FrontEnd.Utils FrontEnd.Warning-  Grin.DeadCode Grin.Arity Grin.Devolve Grin.Embed Grin.FromE Grin.EvalInline Grin.Grin-  Grin.HashConst Grin.Interpret Grin.Lint Grin.NodeAnalyze Grin.Noodle Grin.Optimize-  Grin.SSimplify Grin.Show Grin.Simplify Grin.Unboxing Grin.Val Grin.Whiz Ho.Collected-  Ho.Binary Ho.Build Ho.Library Ho.Type Info.Binary Info.Info Info.Types Info.Properties-  Name.Prim Name.Id Name.Name Name.Names Name.VConsts-  Support.Tuple Support.CFF Support.FreeVars Support.CanType Support.ShowTable-  Support.Tickle Support.Transform Support.Unparse Util.Graph-  Util.Gen Util.ArbitraryInstances Util.BitSet Util.BooleanSolver Util.ContextMonad-  Util.FilterInput Util.ReaderWriter Util.Graphviz Util.HasSize Util.Histogram-  Util.Inst Util.IntBag Util.Interact Util.NameMonad Util.Once Util.Perhaps-  Util.RWS Util.Relation Util.SameShape Util.Seq Util.SetLike-  Util.UnionFind Util.UnionSolve Util.UniqueMonad Util.VarName Util.Util LHCVersion+  ghc-options:       -threaded  Executable lhc-regress   if flag(lhc-regress)@@ -115,10 +162,17 @@   else     Buildable:      False   main-is:          Main.hs+  other-modules:    TestCase, Setup   hs-source-dirs:   lhc-regress/-  build-depends:    process-  if flag(base4)-    build-depends:  base >= 4 && < 5-    cpp-options:    -DBASE4-  else-    build-depends:  base >= 3 && < 4+  build-depends:    base >= 4 && < 5, process, extensible-exceptions++Executable lhc-pkg+  hs-source-dirs: lhc-pkg/+  main-is: Main.hs+  Extensions: CPP, ForeignFunctionInterface+  Other-modules: Paths_lhc++  Build-Depends: base >= 4 && < 5, directory, process, pretty, haskell98, filepath, Cabal+  if !os(windows)+      Build-Depends: unix+
+ lib/base/LICENSE view
@@ -0,0 +1,83 @@+This library (libraries/base) is derived from code from several+sources: ++  * Code from the GHC project which is largely (c) The University of+    Glasgow, and distributable under a BSD-style license (see below),++  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+    and freely redistributable (but see the full license for+    restrictions).++  * Code from the Haskell Foreign Function Interface specification,+    which is (c) Manuel M. T. Chakravarty and freely redistributable+    (but see the full license for restrictions).++The full text of these licenses is reproduced below.  All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++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.++-----------------------------------------------------------------------------
− lib/base/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ lib/base/Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
lib/base/base.cabal view
@@ -1,78 +1,99 @@-Cabal-version:   >= 1.7-Name: base-Version: 1.0-Build-Type: Simple+name:           base+version:        4.1.0.0+license:        BSD3+license-file:   LICENSE+maintainer:     lhc@haskell.org+synopsis:       Basic libraries+description:+    This package contains the Prelude and its support libraries,+    and a large collection of useful libraries ranging from data+    structures to parsing combinators and debugging utilities.+cabal-version:  >=1.2+build-type:     Simple -Library-  Extensions:      ForeignFunctionInterface-  hs-source-dirs:  src-  Exposed-Modules:-                 Control.Exception-                 Control.Applicative-                 Control.Arrow-                 Control.Category-                 Control.Monad-                 Control.Monad.Fix-                 Control.Monad.Instances-                 Data.Array-                 Data.Char,-                 Data.Complex-                 Data.List-                 Data.Word,-                 Data.Monoid-                 Data.Bits-                 Data.Int-                 Data.IORef-                 Data.Ix-                 Data.Maybe-                 Data.Ratio,-                 Data.Unicode-                 Data.Function-                 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,-                 Lhc.Addr,-                 Lhc.Basics,-                 Lhc.Float-                 Lhc.Array-                 Data.Array.IO-                 Data.Array.Unboxed-                 Lhc.Handle,-                 Lhc.IO,-                 Lhc.Tuples,-                 Numeric,-                 Prelude.Float,-                 Prelude.IO,-                 Prelude.IOError,-                 Prelude.Text,-                 Prelude-                 System.Console.GetOpt-                 System.CPUTime-                 System.Directory-                 System.Info-                 System.IO-                 System.IO.Error-                 System.IO.Unsafe,-                 System.IO.Binary-                 System.Locale---                 System.Random,---                 System.Time,-                 System-                 Text.Show.Functions-                 Text.Printf+Library {+   extensions: CPP, NoImplicitPrelude, MagicHash+   build-depends: ghc-prim, integer+   ghc-options: -package-name base -fglasgow-exts+   include-dirs: includes/ -  if !impl(lhc)-    buildable:     False+   Exposed-modules:+      Prelude+      Data.List+      Data.Ix+      Data.Char+      Data.Maybe+      Data.Either+      Data.Tuple+      Data.Bits+      Data.Word+      Data.Int+      Data.HashTable+      Data.Typeable+      Data.Dynamic+      Data.IORef+      Text.ParserCombinators.ReadP+      Text.ParserCombinators.ReadPrec+      Text.Read.Lex+      Text.Show+      Text.Read+      Text.Printf+--      Text.Show.Functions+      Numeric+      System.IO.Unsafe+      System.IO.Error+      System.IO+      System.Posix.Types+      System.Posix.Internals+      System.Environment++      GHC.Base+      GHC.Unicode+      GHC.Read+      GHC.Float+      GHC.Arr+      GHC.Classes+      GHC.Exception+      GHC.Err+      GHC.List+      GHC.Show+      GHC.Enum+      GHC.Num+      GHC.ST+      GHC.STRef+      GHC.Word+      GHC.Int+      GHC.Real+      GHC.Ptr+      GHC.Stable+      GHC.Storable+      GHC.ForeignPtr+      GHC.Pack+      GHC.Conc+      GHC.Handle+      GHC.IO+      GHC.TopHandler+      GHC.IOBase+      Unsafe.Coerce+      Foreign.C.Types+      Foreign.C.String+      Foreign.C.Error+      Foreign.C+      Foreign.Ptr+      Foreign.ForeignPtr+      Foreign.StablePtr+      Foreign.Storable+      Foreign.Marshal.Alloc+      Foreign.Marshal.Utils+      Foreign.Marshal.Array+      Foreign.Marshal.Error+      Foreign.Marshal.Pool+      Foreign.Marshal+      Foreign++      Control.Monad+      Control.Exception.Base+      Control.Exception++   Hs-source-dirs: src+}
+ lib/base/includes/CTypes.h view
@@ -0,0 +1,213 @@+{- --------------------------------------------------------------------------+// Dirty CPP hackery for CTypes/CTypesISO+//+// (c) The FFI task force, 2000+// --------------------------------------------------------------------------+-}++#ifndef CTYPES__H+#define CTYPES__H++{-+//include "Typeable.h"+-}++{-+// As long as there is no automatic derivation of classes for newtypes we resort+// to extremely dirty cpp-hackery.   :-P   Some care has to be taken when the+// macros below are modified, otherwise the layout rule will bite you.+-}++--  // A hacked version for GHC follows the Haskell 98 version...+#ifndef __GLASGOW_HASKELL__++#define ARITHMETIC_TYPE(T,C,S,B) \+newtype T = T B deriving (Eq, Ord) ; \+INSTANCE_NUM(T) ; \+INSTANCE_REAL(T) ; \+INSTANCE_READ(T,B) ; \+INSTANCE_SHOW(T,B) ; \+INSTANCE_ENUM(T) ; \+INSTANCE_STORABLE(T) ; \+INSTANCE_TYPEABLE0(T,C,S) ;++#define INTEGRAL_TYPE(T,C,S,B) \+ARITHMETIC_TYPE(T,C,S,B) ; \+INSTANCE_BOUNDED(T) ; \+INSTANCE_INTEGRAL(T) ; \+INSTANCE_BITS(T)++#define FLOATING_TYPE(T,C,S,B) \+ARITHMETIC_TYPE(T,C,S,B) ; \+INSTANCE_FRACTIONAL(T) ; \+INSTANCE_FLOATING(T) ; \+INSTANCE_REALFRAC(T) ; \+INSTANCE_REALFLOAT(T)++#ifndef __GLASGOW_HASKELL__+#define fakeMap map+#endif++#define INSTANCE_READ(T,B) \+instance Read T where { \+   readsPrec p s = fakeMap (\(x, t) -> (T x, t)) (readsPrec p s) }++#define INSTANCE_SHOW(T,B) \+instance Show T where { \+   showsPrec p (T x) = showsPrec p x }++#define INSTANCE_NUM(T) \+instance Num T where { \+   (T i) + (T j) = T (i + j) ; \+   (T i) - (T j) = T (i - j) ; \+   (T i) * (T j) = T (i * j) ; \+   negate  (T i) = T (negate i) ; \+   abs     (T i) = T (abs    i) ; \+   signum  (T i) = T (signum i) ; \+   fromInteger x = T (fromInteger x) }++#define INSTANCE_BOUNDED(T) \+instance Bounded T where { \+   minBound = T minBound ; \+   maxBound = T maxBound }++#define INSTANCE_ENUM(T) \+instance Enum T where { \+   succ           (T i)             = T (succ i) ; \+   pred           (T i)             = T (pred i) ; \+   toEnum               x           = T (toEnum x) ; \+   fromEnum       (T i)             = fromEnum i ; \+   enumFrom       (T i)             = fakeMap T (enumFrom i) ; \+   enumFromThen   (T i) (T j)       = fakeMap T (enumFromThen i j) ; \+   enumFromTo     (T i) (T j)       = fakeMap T (enumFromTo i j) ; \+   enumFromThenTo (T i) (T j) (T k) = fakeMap T (enumFromThenTo i j k) }++#define INSTANCE_REAL(T) \+instance Real T where { \+   toRational (T i) = toRational i }++#define INSTANCE_INTEGRAL(T) \+instance Integral T where { \+   (T i) `quot`    (T j) = T (i `quot` j) ; \+   (T i) `rem`     (T j) = T (i `rem`  j) ; \+   (T i) `div`     (T j) = T (i `div`  j) ; \+   (T i) `mod`     (T j) = T (i `mod`  j) ; \+   (T i) `quotRem` (T j) = let (q,r) = i `quotRem` j in (T q, T r) ; \+   (T i) `divMod`  (T j) = let (d,m) = i `divMod`  j in (T d, T m) ; \+   toInteger (T i)       = toInteger i }++#define INSTANCE_BITS(T) \+instance Bits T where { \+  (T x) .&.     (T y)   = T (x .&.   y) ; \+  (T x) .|.     (T y)   = T (x .|.   y) ; \+  (T x) `xor`   (T y)   = T (x `xor` y) ; \+  complement    (T x)   = T (complement x) ; \+  shift         (T x) n = T (shift x n) ; \+  rotate        (T x) n = T (rotate x n) ; \+  bit                 n = T (bit n) ; \+  setBit        (T x) n = T (setBit x n) ; \+  clearBit      (T x) n = T (clearBit x n) ; \+  complementBit (T x) n = T (complementBit x n) ; \+  testBit       (T x) n = testBit x n ; \+  bitSize       (T x)   = bitSize x ; \+  isSigned      (T x)   = isSigned x }++#define INSTANCE_FRACTIONAL(T) \+instance Fractional T where { \+   (T x) / (T y)  = T (x / y) ; \+   recip   (T x)  = T (recip x) ; \+   fromRational r = T (fromRational r) }++#define INSTANCE_FLOATING(T) \+instance Floating T where { \+   pi                    = pi ; \+   exp   (T x)           = T (exp   x) ; \+   log   (T x)           = T (log   x) ; \+   sqrt  (T x)           = T (sqrt  x) ; \+   (T x) **        (T y) = T (x ** y) ; \+   (T x) `logBase` (T y) = T (x `logBase` y) ; \+   sin   (T x)           = T (sin   x) ; \+   cos   (T x)           = T (cos   x) ; \+   tan   (T x)           = T (tan   x) ; \+   asin  (T x)           = T (asin  x) ; \+   acos  (T x)           = T (acos  x) ; \+   atan  (T x)           = T (atan  x) ; \+   sinh  (T x)           = T (sinh  x) ; \+   cosh  (T x)           = T (cosh  x) ; \+   tanh  (T x)           = T (tanh  x) ; \+   asinh (T x)           = T (asinh x) ; \+   acosh (T x)           = T (acosh x) ; \+   atanh (T x)           = T (atanh x) }++#define INSTANCE_REALFRAC(T) \+instance RealFrac T where { \+   properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \+   truncate (T x) = truncate x ; \+   round    (T x) = round x ; \+   ceiling  (T x) = ceiling x ; \+   floor    (T x) = floor x }++#define INSTANCE_REALFLOAT(T) \+instance RealFloat T where { \+   floatRadix     (T x) = floatRadix x ; \+   floatDigits    (T x) = floatDigits x ; \+   floatRange     (T x) = floatRange x ; \+   decodeFloat    (T x) = decodeFloat x ; \+   encodeFloat m n      = T (encodeFloat m n) ; \+   exponent       (T x) = exponent x ; \+   significand    (T x) = T (significand  x) ; \+   scaleFloat n   (T x) = T (scaleFloat n x) ; \+   isNaN          (T x) = isNaN x ; \+   isInfinite     (T x) = isInfinite x ; \+   isDenormalized (T x) = isDenormalized x ; \+   isNegativeZero (T x) = isNegativeZero x ; \+   isIEEE         (T x) = isIEEE x ; \+   (T x) `atan2`  (T y) = T (x `atan2` y) }++#define INSTANCE_STORABLE(T) \+instance Storable T where { \+   sizeOf    (T x)       = sizeOf x ; \+   alignment (T x)       = alignment x ; \+   peekElemOff a i       = liftM T (peekElemOff (castPtr a) i) ; \+   pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x }++#else /* __GLASGOW_HASKELL__ */++--  // GHC can derive any class for a newtype, so we make use of that here...++#define ARITHMETIC_CLASSES  Eq,Ord,Num,Enum,Storable,Real+#define INTEGRAL_CLASSES Bounded,Integral,Bits+#define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat++#define ARITHMETIC_TYPE(T,C,S,B) \+newtype T = T B deriving (ARITHMETIC_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;++#define INTEGRAL_TYPE(T,C,S,B) \+newtype T = T B deriving (ARITHMETIC_CLASSES, INTEGRAL_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;++#define FLOATING_TYPE(T,C,S,B) \+newtype T = T B deriving (ARITHMETIC_CLASSES, FLOATING_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;++#define INSTANCE_READ(T,B) \+instance Read T where { \+   readsPrec            = unsafeCoerce# (readsPrec :: Int -> ReadS B); \+   readList             = unsafeCoerce# (readList  :: ReadS [B]); }++#define INSTANCE_SHOW(T,B) \+instance Show T where { \+   showsPrec            = unsafeCoerce# (showsPrec :: Int -> B -> ShowS); \+   show                 = unsafeCoerce# (show :: B -> String); \+   showList             = unsafeCoerce# (showList :: [B] -> ShowS); }++#endif /* __GLASGOW_HASKELL__ */++#endif
+ lib/base/includes/Typeable.h view
@@ -0,0 +1,149 @@+{- --------------------------------------------------------------------------+// Macros to help make Typeable instances.+//+// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines+//+//	instance Typeable/n/ tc+//	instance Typeable a => Typeable/n-1/ (tc a)+//	instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b)+//	...+//	instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an)+// --------------------------------------------------------------------------+-}++#ifndef TYPEABLE_H+#define TYPEABLE_H++#define INSTANCE_TYPEABLE0(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }++#ifdef __GLASGOW_HASKELL__++--  // For GHC, the extra instances follow from general instance declarations+--  // defined in Data.Typeable.++#define INSTANCE_TYPEABLE1(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE2(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE3(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE4(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE5(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE6(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE7(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] }++#else /* !__GLASGOW_HASKELL__ */++#define INSTANCE_TYPEABLE1(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE2(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable1 (tycon a) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE3(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable2 (tycon a) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE4(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable3 (tycon a) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b) => Typeable2 (tycon a b) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable1 (tycon a b c) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (tycon a b c d) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE5(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable4 (tycon a) where { \+  typeOf4 = typeOf4Default }; \+instance (Typeable a, Typeable b) => Typeable3 (tycon a b) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable2 (tycon a b c) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable1 (tycon a b c d) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable (tycon a b c d e) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE6(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable5 (tycon a) where { \+  typeOf5 = typeOf5Default }; \+instance (Typeable a, Typeable b) => Typeable4 (tycon a b) where { \+  typeOf4 = typeOf4Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable3 (tycon a b c) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable2 (tycon a b c d) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable1 (tycon a b c d e) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Typeable (tycon a b c d e f) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE7(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable6 (tycon a) where { \+  typeOf6 = typeOf6Default }; \+instance (Typeable a, Typeable b) => Typeable5 (tycon a b) where { \+  typeOf5 = typeOf5Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable4 (tycon a b c) where { \+  typeOf4 = typeOf4Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable3 (tycon a b c d) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable2 (tycon a b c d e) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Typeable1 (tycon a b c d e f) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g) => Typeable (tycon a b c d e f g) where { \+  typeOf = typeOfDefault }++#endif /* !__GLASGOW_HASKELL__ */++#endif
+ lib/base/includes/ieee-flpt.h view
@@ -0,0 +1,35 @@+/* this file is #included into both C (.c and .hc) and Haskell files */++    /* IEEE format floating-point */+#define IEEE_FLOATING_POINT 1++   /* Radix of exponent representation */+#ifndef FLT_RADIX+# define FLT_RADIX 2+#endif++   /* Number of base-FLT_RADIX digits in the significand of a float */+#ifndef FLT_MANT_DIG+# define FLT_MANT_DIG 24+#endif+   /* Minimum int x such that FLT_RADIX**(x-1) is a normalised float */+#ifndef FLT_MIN_EXP+#  define FLT_MIN_EXP (-125)+#endif+   /* Maximum int x such that FLT_RADIX**(x-1) is a representable float */+#ifndef FLT_MAX_EXP+# define FLT_MAX_EXP 128+#endif++   /* Number of base-FLT_RADIX digits in the significand of a double */+#ifndef DBL_MANT_DIG+# define DBL_MANT_DIG 53+#endif+   /* Minimum int x such that FLT_RADIX**(x-1) is a normalised double */+#ifndef DBL_MIN_EXP+#  define DBL_MIN_EXP (-1021)+#endif+   /* Maximum int x such that FLT_RADIX**(x-1) is a representable double */+#ifndef DBL_MAX_EXP+# define DBL_MAX_EXP 1024+#endif
− lib/base/src/Control/Applicative.hs 
@@ -1,220 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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/base/src/Control/Arrow.hs 
@@ -1,278 +0,0 @@--------------------------------------------------------------------------------- |--- 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 ArrowApply a => 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/base/src/Control/Category.hs 
@@ -1,53 +0,0 @@-{-# LHC_OPTIONS -fcpp -N #-}--------------------------------------------------------------------------------- |--- 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 Lhc.Basics hiding (id,(.))-import qualified Lhc.Basics as 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-#ifndef __HADDOCK__--- Haddock 1.x cannot parse this:-        (.) = (Prelude..)-#endif---- | 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/base/src/Control/Exception.hs view
@@ -1,60 +1,339 @@--- | This is mostly dummy, LHC does not support inexact exceptions.+{-# OPTIONS_GHC -XNoImplicitPrelude #-} -module Control.Exception where+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Exception+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (extended exceptions)+--+-- This module provides support for raising and catching both built-in+-- and user-defined exceptions.+--+-- In addition to exceptions thrown by 'IO' operations, exceptions may+-- be thrown by pure code (imprecise exceptions) or by external events+-- (asynchronous exceptions), but may only be caught in the 'IO' monad.+-- For more details, see:+--+--  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,+--    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,+--    in /PLDI'99/.+--+--  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton+--    Jones, Andy Moran and John Reppy, in /PLDI'01/.+--+--  * /An Extensible Dynamically-Typed Hierarchy of Exceptions/,+--    by Simon Marlow, in /Haskell '06/.+--+----------------------------------------------------------------------------- -import Prelude hiding(catch)-import qualified Prelude as P+module Control.Exception ( -type IOException = IOError+        -- * The Exception type+#ifdef __HUGS__+        SomeException,+#else+        SomeException(..),+#endif+        Exception(..),          -- class+        IOException,            -- instance Eq, Ord, Show, Typeable, Exception+        ArithException(..),     -- instance Eq, Ord, Show, Typeable, Exception+        ArrayException(..),     -- instance Eq, Ord, Show, Typeable, Exception+        AssertionFailed(..),+        AsyncException(..),     -- instance Eq, Ord, Show, Typeable, Exception -data Exception = IOException IOException+#if __GLASGOW_HASKELL__ || __HUGS__+        NonTermination(..),+        NestedAtomically(..),+#endif+#ifdef __NHC__+        System.ExitCode(), -- instance Exception+#endif --- throw :: Exception -> a+        BlockedOnDeadMVar(..),+        BlockedIndefinitely(..),+        Deadlock(..),+        NoMethodError(..),+        PatternMatchFail(..),+        RecConError(..),+        RecSelError(..),+        RecUpdError(..),+        ErrorCall(..), -throwIO :: Exception -> IO a-throwIO (IOException ioe) = ioError ioe+        -- * Throwing exceptions+        throw,+        throwIO,+        ioError,+#ifdef __GLASGOW_HASKELL__+        throwTo,+#endif -catch :: IO a -> (Exception -> IO a) -> IO a-catch c h = P.catch c (h . IOException)+        -- * Catching Exceptions -catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a-catchJust et c h = catch c $ \e -> maybe (throwIO e) h (et e)+        -- $catching -handle :: (Exception -> IO a) -> IO a -> IO a-handle = flip catch+        -- ** Catching all exceptions -handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a-handleJust et h c = catchJust et c h+        -- $catchall -try :: IO a -> IO (Either Exception a)-try c = catch (fmap Right c) (return . Left)+        -- ** The @catch@ functions+        catch,+        catches, Handler(..),+        catchJust, -tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)-tryJust et c = catchJust et (fmap Right c) (return . Left)+        -- ** The @handle@ functions+        handle,+        handleJust, --- FIXME this is wrong!-evaluate :: a -> IO a-evaluate = return+        -- ** The @try@ functions+        try,+        tryJust, --- mapException+        -- ** The @evaluate@ function+        evaluate, -ioErrors (IOException _) = True+        -- ** The @mapException@ function+        mapException, -block, unblock :: IO a -> IO a-block   = id-unblock = id+        -- * Asynchronous Exceptions -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+        -- $async -bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c-bracket_ before after m = bracket before after (const m)+        -- ** Asynchronous exception control -finally :: IO a -> IO b -> IO a-finally cmd end = bracket_ (return ()) (const end) cmd+        -- |The following two functions allow a thread to control delivery of+        -- asynchronous exceptions during a critical region.++        block,+        unblock,+        blocked,++        -- *** Applying @block@ to an exception handler++        -- $block_handler++        -- *** Interruptible operations++        -- $interruptible++        -- * Assertions++        assert,++        -- * Utilities++        bracket,+        bracket_,+        bracketOnError,++        finally,+        onException,++  ) where++import Control.Exception.Base++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import Data.Maybe+#else+import Prelude hiding (catch)+#endif++#ifdef __NHC__+import System (ExitCode())+#endif++-- | You need this when using 'catches'.+data Handler a = forall e . Exception e => Handler (e -> IO a)++{- |+Sometimes you want to catch two different sorts of exception. You could+do something like++> f = expr `catch` \ (ex :: ArithException) -> handleArith ex+>          `catch` \ (ex :: IOException)    -> handleIO    ex++However, there are a couple of problems with this approach. The first is+that having two exception handlers is inefficient. However, the more+serious issue is that the second exception handler will catch exceptions+in the first, e.g. in the example above, if @handleArith@ throws an+@IOException@ then the second exception handler will catch it.++Instead, we provide a function 'catches', which would be used thus:++> f = expr `catches` [Handler (\ (ex :: ArithException) -> handleArith ex),+>                     Handler (\ (ex :: IOException)    -> handleIO    ex)]+-}+catches :: IO a -> [Handler a] -> IO a+catches io handlers = io `catch` catchesHandler handlers++catchesHandler :: [Handler a] -> SomeException -> IO a+catchesHandler handlers e = foldr tryHandler (throw e) handlers+    where tryHandler (Handler handler) res+              = case fromException e of+                Just e' -> handler e'+                Nothing -> res++-- -----------------------------------------------------------------------------+-- Catching exceptions++{- $catching++There are several functions for catching and examining+exceptions; all of them may only be used from within the+'IO' monad.++Here's a rule of thumb for deciding which catch-style function to+use:++ * If you want to do some cleanup in the event that an exception+   is raised, use 'finally', 'bracket' or 'onException'.++ * To recover after an exception and do something else, the best+   choice is to use one of the 'try' family.++ * ... unless you are recovering from an asynchronous exception, in which+   case use 'catch' or 'catchJust'.++The difference between using 'try' and 'catch' for recovery is that in+'catch' the handler is inside an implicit 'block' (see \"Asynchronous+Exceptions\") which is important when catching asynchronous+exceptions, but when catching other kinds of exception it is+unnecessary.  Furthermore it is possible to accidentally stay inside+the implicit 'block' by tail-calling rather than returning from the+handler, which is why we recommend using 'try' rather than 'catch' for+ordinary exception recovery.++A typical use of 'tryJust' for recovery looks like this:++>  do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME"+>     case r of+>       Left  e    -> ...+>       Right home -> ...++-}++-- -----------------------------------------------------------------------------+-- Asynchronous exceptions++{- $async++ #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to+external influences, and can be raised at any point during execution.+'StackOverflow' and 'HeapOverflow' are two examples of+system-generated asynchronous exceptions.++The primary source of asynchronous exceptions, however, is+'throwTo':++>  throwTo :: ThreadId -> Exception -> IO ()++'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one+running thread to raise an arbitrary exception in another thread.  The+exception is therefore asynchronous with respect to the target thread,+which could be doing anything at the time it receives the exception.+Great care should be taken with asynchronous exceptions; it is all too+easy to introduce race conditions by the over zealous use of+'throwTo'.+-}++{- $block_handler+There\'s an implied 'block' around every exception handler in a call+to one of the 'catch' family of functions.  This is because that is+what you want most of the time - it eliminates a common race condition+in starting an exception handler, because there may be no exception+handler on the stack to handle another exception if one arrives+immediately.  If asynchronous exceptions are blocked on entering the+handler, though, we have time to install a new exception handler+before being interrupted.  If this weren\'t the default, one would have+to write something like++>      block (+>           catch (unblock (...))+>                      (\e -> handler)+>      )++If you need to unblock asynchronous exceptions again in the exception+handler, just use 'unblock' as normal.++Note that 'try' and friends /do not/ have a similar default, because+there is no exception handler in this case.  Don't use 'try' for+recovering from an asynchronous exception.+-}++{- $interruptible++Some operations are /interruptible/, which means that they can receive+asynchronous exceptions even in the scope of a 'block'.  Any function+which may itself block is defined as interruptible; this includes+'Control.Concurrent.MVar.takeMVar'+(but not 'Control.Concurrent.MVar.tryTakeMVar'),+and most operations which perform+some I\/O with the outside world.  The reason for having+interruptible operations is so that we can write things like++>      block (+>         a <- takeMVar m+>         catch (unblock (...))+>               (\e -> ...)+>      )++if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,+then this particular+combination could lead to deadlock, because the thread itself would be+blocked in a state where it can\'t receive any asynchronous exceptions.+With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be+safe in the knowledge that the thread can receive exceptions right up+until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.+Similar arguments apply for other interruptible operations like+'System.IO.openFile'.+-}++{- $catchall++It is possible to catch all exceptions, by using the type 'SomeException':++> catch f (\e -> ... (e :: SomeException) ...)++HOWEVER, this is normally not what you want to do!++For example, suppose you want to read a file, but if it doesn't exist+then continue as if it contained \"\".  You might be tempted to just+catch all exceptions and return \"\" in the handler. However, this has+all sorts of undesirable consequences.  For example, if the user+presses control-C at just the right moment then the 'UserInterrupt'+exception will be caught, and the program will continue running under+the belief that the file contains \"\".  Similarly, if another thread+tries to kill the thread reading the file then the 'ThreadKilled'+exception will be ignored.++Instead, you should only catch exactly the exceptions that you really+want. In this case, this would likely be more specific than even+\"any IO exception\"; a permissions error would likely also want to be+handled differently. Instead, you would probably want something like:++> e <- tryJust (guard . isDoesNotExistError) (readFile f)+> let str = either (const "") id e++There are occassions when you really do need to catch any sort of+exception. However, in most cases this is just so you can do some+cleaning up; you aren't actually interested in the exception itself.+For example, if you open a file then you want to close it again,+whether processing the file executes normally or throws an exception.+However, in these cases you can use functions like 'bracket', 'finally'+and 'onException', which never actually pass you the exception, but+just call the cleanup functions at the appropriate points.++But sometimes you really do need to catch any exception, and actually+see what the exception is. One example is at the very top-level of a+program, you may wish to catch any exception, print it to a logfile or+the screen, and then exit gracefully. For these cases, you can use+'catch' (or one of the other exception-catching functions) with the+'SomeException' type.+-}+
+ lib/base/src/Control/Exception/Base.hs view
@@ -0,0 +1,719 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "Typeable.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Exception.Base+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (extended exceptions)+--+-- Extensible exceptions, except for multiple handlers.+--+-----------------------------------------------------------------------------++module Control.Exception.Base (++        -- * The Exception type+#ifdef __HUGS__+        SomeException,+#else+        SomeException(..),+#endif+        Exception(..),+        IOException,+        ArithException(..),+        ArrayException(..),+        AssertionFailed(..),+        AsyncException(..),++#if __GLASGOW_HASKELL__ || __HUGS__+        NonTermination(..),+        NestedAtomically(..),+#endif++        BlockedOnDeadMVar(..),+        BlockedIndefinitely(..),+        Deadlock(..),+        NoMethodError(..),+        PatternMatchFail(..),+        RecConError(..),+        RecSelError(..),+        RecUpdError(..),+        ErrorCall(..),++        -- * Throwing exceptions+        throwIO,+        throw,+        ioError,+#ifdef __GLASGOW_HASKELL__+        throwTo,+#endif++        -- * Catching Exceptions++        -- ** The @catch@ functions+        catch,+        catchJust,++        -- ** The @handle@ functions+        handle,+        handleJust,++        -- ** The @try@ functions+        try,+        tryJust,+        onException,++        -- ** The @evaluate@ function+        evaluate,++        -- ** The @mapException@ function+        mapException,++        -- * Asynchronous Exceptions++        -- ** Asynchronous exception control++        block,+        unblock,+        blocked,++        -- * Assertions++        assert,++        -- * Utilities++        bracket,+        bracket_,+        bracketOnError,++        finally,++#ifdef __GLASGOW_HASKELL__+        -- * Calls for GHC runtime+        recSelError, recConError, irrefutPatError, runtimeError,+        nonExhaustiveGuardsError, patError, noMethodBindingError,+        nonTermination, nestedAtomically,+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import GHC.Show+import GHC.IOBase+import GHC.Exception hiding ( Exception )+import GHC.Conc+#endif++#ifdef __HUGS__+import Prelude hiding (catch)+import Hugs.Prelude (ExitCode(..))+import Hugs.IOExts (unsafePerformIO)+import Hugs.Exception (SomeException(DynamicException, IOException,+                                     ArithException, ArrayException, ExitException),+                       evaluate, IOException, ArithException, ArrayException)+import qualified Hugs.Exception+#endif++import Data.Dynamic+import Data.Either+import Data.Maybe++#ifdef __NHC__+import qualified System.IO.Error as H'98 (catch)+import System.IO.Error (ioError)+import IO              (bracket)+import DIOError         -- defn of IOError type+import System          (ExitCode())+import System.IO.Unsafe (unsafePerformIO)+import Unsafe.Coerce    (unsafeCoerce)++-- minimum needed for nhc98 to pretend it has Exceptions++{-+data Exception   = IOException    IOException+                 | ArithException ArithException+                 | ArrayException ArrayException+                 | AsyncException AsyncException+                 | ExitException  ExitCode+                 deriving Show+-}+class ({-Typeable e,-} Show e) => Exception e where+    toException   :: e -> SomeException+    fromException :: SomeException -> Maybe e++data SomeException = forall e . Exception e => SomeException e++INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")++instance Show SomeException where+    showsPrec p (SomeException e) = showsPrec p e+instance Exception SomeException where+    toException se = se+    fromException = Just++type IOException = IOError+instance Exception IOError where+    toException                     = SomeException+    fromException (SomeException e) = Just (unsafeCoerce e)++instance Exception ExitCode where+    toException                     = SomeException+    fromException (SomeException e) = Just (unsafeCoerce e)++data ArithException+data ArrayException+data AsyncException+data AssertionFailed+data PatternMatchFail+data NoMethodError+data Deadlock+data BlockedOnDeadMVar+data BlockedIndefinitely+data ErrorCall+data RecConError+data RecSelError+data RecUpdError+instance Show ArithException+instance Show ArrayException+instance Show AsyncException+instance Show AssertionFailed+instance Show PatternMatchFail+instance Show NoMethodError+instance Show Deadlock+instance Show BlockedOnDeadMVar+instance Show BlockedIndefinitely+instance Show ErrorCall+instance Show RecConError+instance Show RecSelError+instance Show RecUpdError++catch   :: Exception e+        => IO a         -- ^ The computation to run+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised+        -> IO a+catch io h = H'98.catch  io  (h . fromJust . fromException . toException)++throwIO  :: Exception e => e -> IO a+throwIO   = ioError . fromJust . fromException . toException++throw    :: Exception e => e -> a+throw     = unsafePerformIO . throwIO++evaluate :: a -> IO a+evaluate x = x `seq` return x++assert :: Bool -> a -> a+assert True  x = x+assert False _ = throw (toException (UserError "" "Assertion failed"))++#endif++#ifdef __HUGS__+class (Typeable e, Show e) => Exception e where+    toException   :: e -> SomeException+    fromException :: SomeException -> Maybe e++    toException e = DynamicException (toDyn e) (flip showsPrec e)+    fromException (DynamicException dyn _) = fromDynamic dyn+    fromException _ = Nothing++INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")+INSTANCE_TYPEABLE0(IOException,iOExceptionTc,"IOException")+INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")+INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")+INSTANCE_TYPEABLE0(ExitCode,exitCodeTc,"ExitCode")+INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall")+INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")+INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")+INSTANCE_TYPEABLE0(BlockedOnDeadMVar,blockedOnDeadMVarTc,"BlockedOnDeadMVar")+INSTANCE_TYPEABLE0(BlockedIndefinitely,blockedIndefinitelyTc,"BlockedIndefinitely")+INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")++instance Exception SomeException where+    toException se = se+    fromException = Just++instance Exception IOException where+    toException = IOException+    fromException (IOException e) = Just e+    fromException _ = Nothing++instance Exception ArrayException where+    toException = ArrayException+    fromException (ArrayException e) = Just e+    fromException _ = Nothing++instance Exception ArithException where+    toException = ArithException+    fromException (ArithException e) = Just e+    fromException _ = Nothing++instance Exception ExitCode where+    toException = ExitException+    fromException (ExitException e) = Just e+    fromException _ = Nothing++data ErrorCall = ErrorCall String++instance Show ErrorCall where+    showsPrec _ (ErrorCall err) = showString err++instance Exception ErrorCall where+    toException (ErrorCall s) = Hugs.Exception.ErrorCall s+    fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s)+    fromException _ = Nothing++data BlockedOnDeadMVar = BlockedOnDeadMVar+data BlockedIndefinitely = BlockedIndefinitely+data Deadlock = Deadlock+data AssertionFailed = AssertionFailed String+data AsyncException+  = StackOverflow+  | HeapOverflow+  | ThreadKilled+  | UserInterrupt+  deriving (Eq, Ord)++instance Show BlockedOnDeadMVar where+    showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"++instance Show BlockedIndefinitely where+    showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"++instance Show Deadlock where+    showsPrec _ Deadlock = showString "<<deadlock>>"++instance Show AssertionFailed where+    showsPrec _ (AssertionFailed err) = showString err++instance Show AsyncException where+    showsPrec _ StackOverflow   = showString "stack overflow"+    showsPrec _ HeapOverflow    = showString "heap overflow"+    showsPrec _ ThreadKilled    = showString "thread killed"+    showsPrec _ UserInterrupt   = showString "user interrupt"++instance Exception BlockedOnDeadMVar+instance Exception BlockedIndefinitely+instance Exception Deadlock+instance Exception AssertionFailed+instance Exception AsyncException++throw :: Exception e => e -> a+throw e = Hugs.Exception.throw (toException e)++throwIO :: Exception e => e -> IO a+throwIO e = Hugs.Exception.throwIO (toException e)+#endif++#ifndef __GLASGOW_HASKELL__+-- Dummy definitions for implementations lacking asynchonous exceptions++block   :: IO a -> IO a+block    = id+unblock :: IO a -> IO a+unblock  = id+blocked :: IO Bool+blocked  = return False+#endif++-----------------------------------------------------------------------------+-- Catching exceptions++-- |This is the simplest of the exception-catching functions.  It+-- takes a single argument, runs it, and if an exception is raised+-- the \"handler\" is executed, with the value of the exception passed as an+-- argument.  Otherwise, the result is returned as normal.  For example:+--+-- >   catch (readFile f)+-- >         (\e -> do let err = show (e :: IOException)+-- >                   hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err)+-- >                   return "")+--+-- Note that we have to give a type signature to @e@, or the program+-- will not typecheck as the type is ambiguous. While it is possible+-- to catch exceptions of any type, see $catchall for an explanation+-- of the problems with doing so.+--+-- For catching exceptions in pure (non-'IO') expressions, see the+-- function 'evaluate'.+--+-- Note that due to Haskell\'s unspecified evaluation order, an+-- expression may throw one of several possible exceptions: consider+-- the expression @(error \"urk\") + (1 \`div\` 0)@.  Does+-- the expression throw+-- @ErrorCall \"urk\"@, or @DivideByZero@?+--+-- The answer is \"it might throw either\"; the choice is+-- non-deterministic. If you are catching any type of exception then you+-- might catch either. If you are calling @catch@ with type+-- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may+-- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@+-- exception may be propogated further up. If you call it again, you+-- might get a the opposite behaviour. This is ok, because 'catch' is an+-- 'IO' computation.+--+-- Note that the "Prelude" also exports a function called+-- 'Prelude.catch' with a similar type to 'Control.Exception.catch',+-- except that the "Prelude" version only catches the IO and user+-- families of exceptions (as required by Haskell 98).+--+-- We recommend either hiding the "Prelude" version of 'Prelude.catch'+-- when importing "Control.Exception":+--+-- > import Prelude hiding (catch)+--+-- or importing "Control.Exception" qualified, to avoid name-clashes:+--+-- > import qualified Control.Exception as C+--+-- and then using @C.catch@+--+#ifndef __NHC__+catch   :: Exception e+        => IO a         -- ^ The computation to run+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised+        -> IO a+#if __GLASGOW_HASKELL__+catch = GHC.IOBase.catchException+#elif __HUGS__+catch m h = Hugs.Exception.catchException m h'+  where h' e = case fromException e of+            Just e' -> h e'+            Nothing -> throwIO e+#endif+#endif++-- | The function 'catchJust' is like 'catch', but it takes an extra+-- argument which is an /exception predicate/, a function which+-- selects which type of exceptions we\'re interested in.+--+-- > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing)+-- >           (readFile f)+-- >           (\_ -> do hPutStrLn stderr ("No such file: " ++ show f)+-- >                     return "")+--+-- Any other exceptions which are not matched by the predicate+-- are re-raised, and may be caught by an enclosing+-- 'catch', 'catchJust', etc.+catchJust+        :: Exception e+        => (e -> Maybe b)         -- ^ Predicate to select exceptions+        -> IO a                   -- ^ Computation to run+        -> (b -> IO a)            -- ^ Handler+        -> IO a+catchJust p a handler = catch a handler'+  where handler' e = case p e of+                        Nothing -> throw e+                        Just b  -> handler b++-- | A version of 'catch' with the arguments swapped around; useful in+-- situations where the code for the handler is shorter.  For example:+--+-- >   do handle (\NonTermination -> exitWith (ExitFailure 1)) $+-- >      ...+handle     :: Exception e => (e -> IO a) -> IO a -> IO a+handle     =  flip catch++-- | A version of 'catchJust' with the arguments swapped around (see+-- 'handle').+handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a+handleJust p =  flip (catchJust p)++-----------------------------------------------------------------------------+-- 'mapException'++-- | This function maps one exception into another as proposed in the+-- paper \"A semantics for imprecise exceptions\".++-- Notice that the usage of 'unsafePerformIO' is safe here.++mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a+mapException f v = unsafePerformIO (catch (evaluate v)+                                          (\x -> throw (f x)))++-----------------------------------------------------------------------------+-- 'try' and variations.++-- | Similar to 'catch', but returns an 'Either' result which is+-- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@+-- if an exception of type @e@ was raised and its value is @ex@.+-- If any other type of exception is raised than it will be propogated+-- up to the next enclosing exception handler.+--+-- >  try a = catch (Right `liftM` a) (return . Left)+--+-- Note that "System.IO.Error" also exports a function called+-- 'System.IO.Error.try' with a similar type to 'Control.Exception.try',+-- except that it catches only the IO and user families of exceptions+-- (as required by the Haskell 98 @IO@ module).++try :: Exception e => IO a -> IO (Either e a)+try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))++-- | A variant of 'try' that takes an exception predicate to select+-- which exceptions are caught (c.f. 'catchJust').  If the exception+-- does not match the predicate, it is re-thrown.+tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)+tryJust p a = do+  r <- try a+  case r of+        Right v -> return (Right v)+        Left  e -> case p e of+                        Nothing -> throw e+                        Just b  -> return (Left b)++-- | Like 'finally', but only performs the final action if there was an+-- exception raised by the computation.+onException :: IO a -> IO b -> IO a+onException io what = io `catch` \e -> do what+                                          throw (e :: SomeException)++-----------------------------------------------------------------------------+-- Some Useful Functions++-- | When you want to acquire a resource, do some work with it, and+-- then release the resource, it is a good idea to use 'bracket',+-- because 'bracket' will install the necessary exception handler to+-- release the resource in the event that an exception is raised+-- during the computation.  If an exception is raised, then 'bracket' will+-- re-raise the exception (after performing the release).+--+-- A common example is opening a file:+--+-- > bracket+-- >   (openFile "filename" ReadMode)+-- >   (hClose)+-- >   (\fileHandle -> do { ... })+--+-- The arguments to 'bracket' are in this order so that we can partially apply+-- it, e.g.:+--+-- > withFile name mode = bracket (openFile name mode) hClose+--+#ifndef __NHC__+bracket+        :: IO a         -- ^ computation to run first (\"acquire resource\")+        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")+        -> (a -> IO c)  -- ^ computation to run in-between+        -> IO c         -- returns the value from the in-between computation+bracket before after thing =+  block (do+    a <- before+    r <- unblock (thing a) `onException` after a+    after a+    return r+ )+#endif++-- | A specialised variant of 'bracket' with just a computation to run+-- afterward.+--+finally :: IO a         -- ^ computation to run first+        -> IO b         -- ^ computation to run afterward (even if an exception+                        -- was raised)+        -> IO a         -- returns the value from the first computation+a `finally` sequel =+  block (do+    r <- unblock a `onException` sequel+    sequel+    return r+  )++-- | A variant of 'bracket' where the return value from the first computation+-- is not required.+bracket_ :: IO a -> IO b -> IO c -> IO c+bracket_ before after thing = bracket before (const after) (const thing)++-- | Like 'bracket', but only performs the final action if there was an+-- exception raised by the in-between computation.+bracketOnError+        :: IO a         -- ^ computation to run first (\"acquire resource\")+        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")+        -> (a -> IO c)  -- ^ computation to run in-between+        -> IO c         -- returns the value from the in-between computation+bracketOnError before after thing =+  block (do+    a <- before+    unblock (thing a) `onException` after a+  )++#if !(__GLASGOW_HASKELL__ || __NHC__)+assert :: Bool -> a -> a+assert True x = x+assert False _ = throw (AssertionFailed "")+#endif++-----++#if __GLASGOW_HASKELL__ || __HUGS__+-- |A pattern match failed. The @String@ gives information about the+-- source location of the pattern.+data PatternMatchFail = PatternMatchFail String+INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")++instance Show PatternMatchFail where+    showsPrec _ (PatternMatchFail err) = showString err++#ifdef __HUGS__+instance Exception PatternMatchFail where+    toException (PatternMatchFail err) = Hugs.Exception.PatternMatchFail err+    fromException (Hugs.Exception.PatternMatchFail err) = Just (PatternMatchFail err)+    fromException _ = Nothing+#else+instance Exception PatternMatchFail+#endif++-----++-- |A record selector was applied to a constructor without the+-- appropriate field. This can only happen with a datatype with+-- multiple constructors, where some fields are in one constructor+-- but not another. The @String@ gives information about the source+-- location of the record selector.+data RecSelError = RecSelError String+INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")++instance Show RecSelError where+    showsPrec _ (RecSelError err) = showString err++#ifdef __HUGS__+instance Exception RecSelError where+    toException (RecSelError err) = Hugs.Exception.RecSelError err+    fromException (Hugs.Exception.RecSelError err) = Just (RecSelError err)+    fromException _ = Nothing+#else+instance Exception RecSelError+#endif++-----++-- |An uninitialised record field was used. The @String@ gives+-- information about the source location where the record was+-- constructed.+data RecConError = RecConError String+INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")++instance Show RecConError where+    showsPrec _ (RecConError err) = showString err++#ifdef __HUGS__+instance Exception RecConError where+    toException (RecConError err) = Hugs.Exception.RecConError err+    fromException (Hugs.Exception.RecConError err) = Just (RecConError err)+    fromException _ = Nothing+#else+instance Exception RecConError+#endif++-----++-- |A record update was performed on a constructor without the+-- appropriate field. This can only happen with a datatype with+-- multiple constructors, where some fields are in one constructor+-- but not another. The @String@ gives information about the source+-- location of the record update.+data RecUpdError = RecUpdError String+INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")++instance Show RecUpdError where+    showsPrec _ (RecUpdError err) = showString err++#ifdef __HUGS__+instance Exception RecUpdError where+    toException (RecUpdError err) = Hugs.Exception.RecUpdError err+    fromException (Hugs.Exception.RecUpdError err) = Just (RecUpdError err)+    fromException _ = Nothing+#else+instance Exception RecUpdError+#endif++-----++-- |A class method without a definition (neither a default definition,+-- nor a definition in the appropriate instance) was called. The+-- @String@ gives information about which method it was.+data NoMethodError = NoMethodError String+INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")++instance Show NoMethodError where+    showsPrec _ (NoMethodError err) = showString err++#ifdef __HUGS__+instance Exception NoMethodError where+    toException (NoMethodError err) = Hugs.Exception.NoMethodError err+    fromException (Hugs.Exception.NoMethodError err) = Just (NoMethodError err)+    fromException _ = Nothing+#else+instance Exception NoMethodError+#endif++-----++-- |Thrown when the runtime system detects that the computation is+-- guaranteed not to terminate. Note that there is no guarantee that+-- the runtime system will notice whether any given computation is+-- guaranteed to terminate or not.+data NonTermination = NonTermination+INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")++instance Show NonTermination where+    showsPrec _ NonTermination = showString "<<loop>>"++#ifdef __HUGS__+instance Exception NonTermination where+    toException NonTermination = Hugs.Exception.NonTermination+    fromException Hugs.Exception.NonTermination = Just NonTermination+    fromException _ = Nothing+#else+instance Exception NonTermination+#endif++-----++-- |Thrown when the program attempts to call @atomically@, from the @stm@+-- package, inside another call to @atomically@.+data NestedAtomically = NestedAtomically+INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")++instance Show NestedAtomically where+    showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"++instance Exception NestedAtomically++-----++instance Exception Dynamic++#endif /* __GLASGOW_HASKELL__ || __HUGS__ */++#ifdef __GLASGOW_HASKELL__+recSelError, recConError, irrefutPatError, runtimeError,+             nonExhaustiveGuardsError, patError, noMethodBindingError+        :: Addr# -> a   -- All take a UTF8-encoded C string++recSelError              s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately+runtimeError             s = error (unpackCStringUtf8# s)               -- No location info unfortunately++nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))+irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))+recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))+noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))+patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))++-- GHC's RTS calls this+nonTermination :: SomeException+nonTermination = toException NonTermination++-- GHC's RTS calls this+nestedAtomically :: SomeException+nestedAtomically = toException NestedAtomically+#endif
lib/base/src/Control/Monad.hs view
@@ -1,114 +1,165 @@-module Control.Monad(-    MonadPlus(mzero, mplus),-    join, guard, when, unless, ap, msum,-    filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM,-    liftM, liftM2, liftM3, liftM4, liftM5,+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad+-- 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 'Functor', 'Monad' and 'MonadPlus' classes,+-- with some useful operations on monads. -    foldM_,replicateM,replicateM_,(>=>),(<=<),forever,+module Control.Monad+    (+    -- * Functor and monad classes -    -- ...and what the Prelude exports-    Monad((>>=), (>>), return, fail),-    Functor(fmap),-    mapM, mapM_, sequence, sequence_, (=<<)-)where+      Functor(fmap)+    , Monad((>>=), (>>), return, fail) -import Lhc.Basics+    , MonadPlus (   -- class context: Monad+          mzero     -- :: (MonadPlus m) => m a+        , mplus     -- :: (MonadPlus m) => m a -> m a -> m a+        )+    -- * Functions -class Monad m => MonadPlus m where-    mzero :: m a-    mplus :: m a -> m a -> m a-    mzero = fail "mzero"+    -- ** Naming conventions+    -- $naming +    -- ** Basic functions from the "Prelude" -instance MonadPlus Maybe where-    mzero = Nothing-    Nothing `mplus` y = y-    x `mplus` _ = x+    , mapM          -- :: (Monad m) => (a -> m b) -> [a] -> m [b]+    , mapM_         -- :: (Monad m) => (a -> m b) -> [a] -> m ()+    , forM          -- :: (Monad m) => [a] -> (a -> m b) -> m [b]+    , forM_         -- :: (Monad m) => [a] -> (a -> m b) -> m ()+    , sequence      -- :: (Monad m) => [m a] -> m [a]+    , sequence_     -- :: (Monad m) => [m a] -> m ()+    , (=<<)         -- :: (Monad m) => (a -> m b) -> m a -> m b+    , (>=>)         -- :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c)+    , (<=<)         -- :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)+    , forever       -- :: (Monad m) => m a -> m b -instance MonadPlus [] where-    mzero = []-    mplus = (++)+    -- ** Generalisations of list functions +    , join          -- :: (Monad m) => m (m a) -> m a+    , msum          -- :: (MonadPlus m) => [m a] -> m a+    , filterM       -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+    , mapAndUnzipM  -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+    , zipWithM      -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+    , zipWithM_     -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+    , foldM         -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +    , foldM_        -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()+    , replicateM    -- :: (Monad m) => Int -> m a -> m [a]+    , replicateM_   -- :: (Monad m) => Int -> m a -> m () --- Functions+    -- ** Conditional execution of monadic expressions +    , guard         -- :: (MonadPlus m) => Bool -> m ()+    , when          -- :: (Monad m) => Bool -> m () -> m ()+    , unless        -- :: (Monad m) => Bool -> m () -> m () -msum  :: MonadPlus m => [m a] -> m a-msum xs  =  foldr mplus mzero xs+    -- ** Monadic lifting operators -join             :: (Monad m) => m (m a) -> m a-join x           =  x >>= id+    , liftM         -- :: (Monad m) => (a -> b) -> (m a -> m b)+    , liftM2        -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)+    , liftM3        -- :: ...+    , liftM4        -- :: ...+    , liftM5        -- :: ... -when             :: (Monad m) => Bool -> m () -> m ()-when p s         =  if p then s else return ()+    , ap            -- :: (Monad m) => m (a -> b) -> m a -> m b -unless           :: (Monad m) => Bool -> m () -> m ()-unless p s       =  when (not p) s+    ) where -ap               :: (Monad m) => m (a -> b) -> m a -> m b-ap               =  liftM2 ($)+import Data.Maybe -guard            :: MonadPlus m => Bool -> m ()-guard p          =  if p then return () else mzero+#ifdef __GLASGOW_HASKELL__+import GHC.List+import GHC.Base+#endif -mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])-mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip+#ifdef __GLASGOW_HASKELL__+infixr 1 =<< -zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]-zipWithM f xs ys =  sequence (zipWith f xs ys)+-- -----------------------------------------------------------------------------+-- Prelude monad functions -zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()-zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)+-- | Same as '>>=', but with the arguments interchanged.+{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}+(=<<)           :: Monad m => (a -> m b) -> m a -> m b+f =<< x         = x >>= f -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+-- | Evaluate each action in the sequence from left to right,+-- and collect the results.+sequence       :: Monad m => [m a] -> m [a] +{-# INLINE sequence #-}+sequence ms = foldr k (return []) ms+            where+              k m m' = do { x <- m; xs <- m'; return (x: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)-   }+-- | Evaluate each action in the sequence from left to right,+-- and ignore the results.+sequence_        :: Monad m => [m a] -> m () +{-# INLINE sequence_ #-}+sequence_ ms     =  foldr (>>) (return ()) ms -liftM            :: (Monad m) => (a -> b) -> (m a -> m b)-liftM f          =  \a -> do { a' <- a; return (f a') }+-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@.+mapM            :: Monad m => (a -> m b) -> [a] -> m [b]+{-# INLINE mapM #-}+mapM f as       =  sequence (map f as) -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') }+-- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@.+mapM_           :: Monad m => (a -> m b) -> [a] -> m ()+{-# INLINE mapM_ #-}+mapM_ f as      =  sequence_ (map f as) -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') }+#endif  /* __GLASGOW_HASKELL__ */ -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') }+-- -----------------------------------------------------------------------------+-- The MonadPlus class definition -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') }+-- | Monads that also support choice and failure.+class Monad m => MonadPlus m where+   -- | the identity of 'mplus'.  It should also satisfy the equations+   --+   -- > mzero >>= f  =  mzero+   -- > v >> mzero   =  mzero+   --+   -- (but the instance for 'System.IO.IO' defined in Control.Monad.Error+   -- in the mtl package does not satisfy the second one).+   mzero :: m a +   -- | an associative operation+   mplus :: m a -> m a -> m a +instance MonadPlus [] where+   mzero = []+   mplus = (++) --- extensions+instance MonadPlus Maybe where+   mzero = Nothing --- | 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 ()+   Nothing `mplus` ys  = ys+   xs      `mplus` _ys = xs --- | @'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)+-- -----------------------------------------------------------------------------+-- Functions mandated by the Prelude --- | Like 'replicateM', but discards the result.-replicateM_       :: (Monad m) => Int -> m a -> m ()-replicateM_ n x   = sequence_ (replicate n x)+-- | @'guard' b@ is @'return' ()@ if @b@ is 'True',+-- and 'mzero' if @b@ is 'False'.+guard           :: (MonadPlus m) => Bool -> m ()+guard True      =  return ()+guard False     =  mzero +-- | This generalizes the list-based 'filter' function. +filterM          :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+filterM _ []     =  return []+filterM p (x:xs) =  do+   flg <- p x+   ys  <- filterM p xs+   return (if flg then x:ys else ys)+ -- | 'forM' is 'mapM' with its arguments flipped forM            :: Monad m => [a] -> (a -> m b) -> m [b] {-# INLINE forM #-}@@ -119,18 +170,165 @@ {-# INLINE forM_ #-} forM_           = flip mapM_ +-- | This generalizes the list-based 'concat' function.++msum        :: MonadPlus m => [m a] -> m a+{-# INLINE msum #-}+msum        =  foldr mplus mzero+ 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+-- | 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     :: (Monad m) => m a -> m b forever a   = a >> forever a +-- -----------------------------------------------------------------------------+-- Other monad functions++-- | The 'join' function is the conventional monad join operator. It is used to+-- remove one level of monadic structure, projecting its bound argument into the+-- outer level.+join              :: (Monad m) => m (m a) -> m a+join x            =  x >>= id++-- | The 'mapAndUnzipM' function maps its first argument over a list, returning+-- the result as a pair of lists. This function is mainly used with complicated+-- data structures or a state-transforming monad.+mapAndUnzipM      :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs =  sequence (map f xs) >>= return . unzip++-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads.+zipWithM          :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys  =  sequence (zipWith f xs ys)++-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.+zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++{- | The 'foldM' function is analogous to 'foldl', except that its result is+encapsulated in a monad. Note that 'foldM' works from left-to-right over+the list arguments. This could be an issue where '(>>)' and the `folded+function' are not commutative.+++>       foldM f a1 [x1, x2, ..., xm ]++==  ++>       do+>         a2 <- f a1 x1+>         a3 <- f a2 x2+>         ...+>         f am xm++If right-to-left evaluation is required, the input list should be reversed.+-}++foldM             :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM _ a []      =  return a+foldM f a (x:xs)  =  f a x >>= \fax -> foldM f fax xs++-- | 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)++{- | Conditional execution of monadic expressions. For example, ++>       when debug (putStr "Debugging\n")++will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True',+and otherwise do nothing.+-}++when              :: (Monad m) => Bool -> m () -> m ()+when p s          =  if p then s else return ()++-- | The reverse of 'when'.++unless            :: (Monad m) => Bool -> m () -> m ()+unless p s        =  if p then return () else s++-- | Promote a function to a monad.+liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r+liftM f m1              = do { x1 <- m1; return (f x1) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right.  For example,+--+-- >    liftM2 (+) [0,1] [0,2] = [0,2,1,3]+-- >    liftM2 (+) (Just 1) Nothing = Nothing+--+liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r+liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right (cf. 'liftM2').+liftM3  :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r+liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right (cf. 'liftM2').+liftM4  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r+liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right (cf. 'liftM2').+liftM5  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }++{- | In many situations, the 'liftM' operations can be replaced by uses of+'ap', which promotes function application. ++>       return f `ap` x1 `ap` ... `ap` xn++is equivalent to ++>       liftMn f x1 x2 ... xn++-}++ap                :: (Monad m) => m (a -> b) -> m a -> m b+ap                =  liftM2 id+++{- $naming++The functions in this library use the following naming conventions: ++* A postfix \'@M@\' always stands for a function in the Kleisli category:+  The monad type constructor @m@ is added to function results+  (modulo currying) and nowhere else.  So, for example, ++>  filter  ::              (a ->   Bool) -> [a] ->   [a]+>  filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]++* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.+  Thus, for example: ++>  sequence  :: Monad m => [m a] -> m [a] +>  sequence_ :: Monad m => [m a] -> m () ++* A prefix \'@m@\' generalizes an existing function to a monadic form.+  Thus, for example: ++>  sum  :: Num a       => [a]   -> a+>  msum :: MonadPlus m => [m a] -> m a++-}
− lib/base/src/Control/Monad/Fix.hs 
@@ -1,80 +0,0 @@-{-# LHC_OPTIONS -fcpp #-}--------------------------------------------------------------------------------- |--- 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 Prelude-import System.IO-import Control.Monad.Instances ()-import Data.Function (fix)-#ifdef __HUGS__-import Hugs.Prelude (MonadFix(mfix))-#endif--#ifndef __HUGS__--- | 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-#endif /* !__HUGS__ */---- 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/base/src/Control/Monad/Instances.hs 
@@ -1,31 +0,0 @@-{-# OPTIONS_NHC98 --prelude #-}--------------------------------------------------------------------------------- |--- 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--import Prelude--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/base/src/Data/Array.hs 
@@ -1,90 +0,0 @@-{-# OPTIONS_LHC -funboxed-tuples #-}-module  Data.Array (-    module Ix,  -- export all of Ix-    Array(),-    array,-    listArray,-    (!),-    bounds,-    indices,-    elems,-    assocs,-    accumArray,-    (//),-    accum,-    ixmap-    ) where--import Data.Ix-import Lhc.Array-import Lhc.Int--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-
− lib/base/src/Data/Array/IO.hs 
@@ -1,51 +0,0 @@-{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}-module Data.Array.IO where--import Lhc.Basics-import Data.Ix-import Lhc.Array-import Lhc.IO-import Lhc.Int-import Data.Array--data IOArray a b = IOA !a !a (MutArray__ b)--newIOArray :: Ix a => (a,a) -> b -> IO (IOArray a b)-newIOArray rng fill = IO (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 newMutArray__ 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' -> IO (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' -> IO (\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' -> IO (readArray__ arr i')--unsafeWriteIOArray :: Ix a => IOArray a b -> Int -> b -> IO ()-unsafeWriteIOArray (IOA l h arr) i x =-    case unboxInt i of i' -> IO (\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/base/src/Data/Array/Unboxed.hs 
@@ -1,82 +0,0 @@-module Data.Array.Unboxed where--import Data.Ix-import System.IO.Unsafe-import Foreign.Storable-import Foreign.Marshal.Alloc-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/base/src/Data/Bits.hs view
@@ -1,24 +1,76 @@-{-# OPTIONS_LHC -N -fffi -fm4 #-}-module Data.Bits where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bits+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- This module defines bitwise operations for signed and unsigned+-- integers.  Instances of the class 'Bits' for the 'Int' and+-- 'Integer' types are available from this module, and instances for+-- explicitly sized integral types are available from the+-- "Data.Int" and "Data.Word" modules.+--+----------------------------------------------------------------------------- +module Data.Bits ( +  Bits(+    (.&.), (.|.), xor, -- :: a -> a -> a+    complement,        -- :: a -> a+    shift,             -- :: a -> Int -> a+    rotate,            -- :: a -> Int -> a+    bit,               -- :: Int -> a+    setBit,            -- :: a -> Int -> a+    clearBit,          -- :: a -> Int -> a+    complementBit,     -- :: a -> Int -> a+    testBit,           -- :: a -> Int -> Bool+    bitSize,           -- :: a -> Int+    isSigned,          -- :: a -> Bool+    shiftL, shiftR,    -- :: a -> Int -> a+    rotateL, rotateR   -- :: a -> Int -> a+  ) -import Lhc.Num-import Lhc.Order-import Lhc.Types-import Data.Int-import Lhc.Prim+  -- instance Bits Int+  -- instance Bits Integer+ ) where +-- Defines the @Bits@ class containing bit-based operations.+-- See library document for details on the semantics of the+-- individual operations.++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#)+#define WORD_SIZE_IN_BITS (WORD_SIZE * 8)+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Num+import GHC.Real+import GHC.Base+#endif++#ifdef __HUGS__+import Hugs.Bits+#endif+ 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.++Minimal complete definition: '.&.', '.|.', 'xor', 'complement',+('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),+'bitSize' and 'isSigned'. -} class Num a => Bits a where     -- | Bitwise \"and\"@@ -33,31 +85,34 @@     {-| 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.+    {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive,+        or right by @-i@ bits otherwise.+        Right shifts perform sign extension on signed number types;+        i.e. they fill the top bits with 1 if the @x@ is negative+        and with 0 otherwise. -	An instance can define either this unified 'shift' or 'shiftL' and-	'shiftR', depending on which is more convenient for the type in-	question. -}+        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+    x `shift`   i | i<0       = x `shiftR` (-i)+                  | i>0       = x `shiftL` i+                  | otherwise = x -    {-| Rotate the argument left by the specified number of bits.-	Right rotates are specified by giving a negative value.+    {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive,+        or right by @-i@ bits otherwise.          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. -}+        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+    x `rotate`  i | i<0       = x `rotateR` (-i)+                  | i>0       = x `rotateL` i+                  | otherwise = x      {-     -- Rotation can be implemented in terms of two shifts, but care is@@ -89,9 +144,9 @@     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'.-	-}+        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@@ -105,58 +160,202 @@     x `testBit` i       = (x .&. bit i) /= 0      {-| Shift the argument left by the specified number of bits-	(which must be non-negative).+        (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. -}+        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).+    {-| Shift the first argument right by the specified number of bits+        (which must be non-negative).+        Right shifts perform sign extension on signed number types;+        i.e. they fill the top bits with 1 if the @x@ is negative+        and with 0 otherwise. -	An instance can define either this and 'shiftL' or the unified-	'shift', depending on which is more convenient for the type in-	question. -}+        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).+        (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. -}+        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).+        (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. -}+        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) +instance Bits Int where+    {-# INLINE shift #-} -m4_define(INST_BITS,{{-instance Bits $1 where-    $1 x .&. $1 y = $1 (and$1 x y)-    $1 x .|. $1 y = $1 (or$1 x y)-    $1 x `xor` $1 y = $1 (xor$1 x y)-    complement ($1 x) = $1 (complement$1 x)-    shiftL ($1 x) (Int bits) = $1 (shiftL$1 x bits)-    shiftR ($1 x) (Int bits) = $1 (shiftR$1 x bits)+#ifdef __GLASGOW_HASKELL__+    (I# x#) .&.   (I# y#)  = I# (word2Int# (int2Word# x# `and#` int2Word# y#)) -foreign import primitive "And" and$1 :: $2 -> $2 -> $2-foreign import primitive "Or" or$1 :: $2 -> $2 -> $2-foreign import primitive "Xor" xor$1 :: $2 -> $2 -> $2-foreign import primitive "Com" complement$1 :: $2 -> $2-foreign import primitive "Shl" shiftL$1 :: $2 -> Bits32_ -> $2-foreign import primitive "Shra" shiftR$1 :: $2 -> Bits32_ -> $2+    (I# x#) .|.   (I# y#)  = I# (word2Int# (int2Word# x# `or#`  int2Word# y#)) -}})+    (I# x#) `xor` (I# y#)  = I# (word2Int# (int2Word# x# `xor#` int2Word# y#)) -INST_BITS(Int,Bits32_)+    complement (I# x#)     = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))++    (I# x#) `shift` (I# i#)+        | i# >=# 0#        = I# (x# `iShiftL#` i#)+        | otherwise        = I# (x# `iShiftRA#` negateInt# i#)++    {-# INLINE rotate #-} 	-- See Note [Constant folding for rotate]+    (I# x#) `rotate` (I# i#) =+        I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                       (x'# `uncheckedShiftRL#` (wsib -# i'#))))+      where+        x'# = int2Word# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        wsib = WORD_SIZE_IN_BITS_   {- work around preprocessor problem (??) -}+    bitSize  _             = WORD_SIZE_IN_BITS++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)+#else /* !__GLASGOW_HASKELL__ */++#ifdef __HUGS__+    (.&.)                  = primAndInt+    (.|.)                  = primOrInt+    xor                    = primXorInt+    complement             = primComplementInt+    shift                  = primShiftInt+    bit                    = primBitInt+    testBit                = primTestInt+    bitSize _              = SIZEOF_HSINT*8+#elif defined(__NHC__)+    (.&.)                  = nhc_primIntAnd+    (.|.)                  = nhc_primIntOr+    xor                    = nhc_primIntXor+    complement             = nhc_primIntCompl+    shiftL                 = nhc_primIntLsh+    shiftR                 = nhc_primIntRsh+    bitSize _              = 32+#endif /* __NHC__ */++    x `rotate`  i+        | i<0 && 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))++#endif /* !__GLASGOW_HASKELL__ */++    isSigned _             = True++#ifdef __NHC__+foreign import ccall nhc_primIntAnd :: Int -> Int -> Int+foreign import ccall nhc_primIntOr  :: Int -> Int -> Int+foreign import ccall nhc_primIntXor :: Int -> Int -> Int+foreign import ccall nhc_primIntLsh :: Int -> Int -> Int+foreign import ccall nhc_primIntRsh :: Int -> Int -> Int+foreign import ccall nhc_primIntCompl :: Int -> Int+#endif /* __NHC__ */++instance Bits Integer where+#if defined(__GLASGOW_HASKELL__)+   (.&.) = andInteger+   (.|.) = orInteger+   xor = xorInteger+   complement = complementInteger+#else+   -- reduce bitwise binary operations to special cases we can handle++   x .&. y   | x<0 && y<0 = complement (complement x `posOr` complement y)+             | otherwise  = x `posAnd` y+   +   x .|. y   | x<0 || y<0 = complement (complement x `posAnd` complement y)+             | otherwise  = x `posOr` y+   +   x `xor` y | x<0 && y<0 = complement x `posXOr` complement y+             | x<0        = complement (complement x `posXOr` y)+             |        y<0 = complement (x `posXOr` complement y)+             | otherwise  = x `posXOr` y++   -- assuming infinite 2's-complement arithmetic+   complement a = -1 - a+#endif++   shift x i | i >= 0    = x * 2^i+             | otherwise = x `div` 2^(-i)++   rotate x i = shift x i   -- since an Integer never wraps around++   bitSize _  = error "Data.Bits.bitSize(Integer)"+   isSigned _ = True++#if !defined(__GLASGOW_HASKELL__)+-- Crude implementation of bitwise operations on Integers: convert them+-- to finite lists of Ints (least significant first), zip and convert+-- back again.++-- posAnd requires at least one argument non-negative+-- posOr and posXOr require both arguments non-negative++posAnd, posOr, posXOr :: Integer -> Integer -> Integer+posAnd x y   = fromInts $ zipWith (.&.) (toInts x) (toInts y)+posOr x y    = fromInts $ longZipWith (.|.) (toInts x) (toInts y)+posXOr x y   = fromInts $ longZipWith xor (toInts x) (toInts y)++longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]+longZipWith f xs [] = xs+longZipWith f [] ys = ys+longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys++toInts :: Integer -> [Int]+toInts n+    | n == 0 = []+    | otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)+  where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)+                | otherwise = fromInteger n++fromInts :: [Int] -> Integer+fromInts = foldr catInt 0+    where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d++numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1+#endif /* !__GLASGOW_HASKELL__ */++{- 	Note [Constant folding for rotate]+	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The INLINE on the Int instance of rotate enables it to be constant+folded.  For example:+     sumU . mapU (`rotate` 3) . replicateU 10000000 $ (7 :: Int)+goes to:+   Main.$wfold =+     \ (ww_sO7 :: Int#) (ww1_sOb :: Int#) ->+       case ww1_sOb of wild_XM {+         __DEFAULT -> Main.$wfold (+# ww_sO7 56) (+# wild_XM 1);+         10000000 -> ww_sO7+whereas before it was left as a call to $wrotate.++All other Bits instances seem to inline well enough on their+own to enable constant folding; for example 'shift':+     sumU . mapU (`shift` 3) . replicateU 10000000 $ (7 :: Int)+ goes to:+     Main.$wfold =+       \ (ww_sOb :: Int#) (ww1_sOf :: Int#) ->+         case ww1_sOf of wild_XM {+           __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1);+           10000000 -> ww_sOb+         }+-} +     +
lib/base/src/Data/Char.hs view
@@ -1,85 +1,213 @@-module Data.Char (-    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,-    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,-    digitToInt, intToDigit,-    toUpper, toLower,-    ord, chr,-    readLitChar, showLitChar, lexLitChar,-    module Prelude.CType,+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Char+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Char type and associated operations.+--+----------------------------------------------------------------------------- -        -- ...and what the Prelude exports-    Char, String+module Data.Char+    (+      Char++    , String++    -- * Character classification+    -- | Unicode characters are divided into letters, numbers, marks,+    -- punctuation, symbols, separators (including spaces) and others+    -- (including control characters).+    , isControl, isSpace+    , isLower, isUpper, isAlpha, isAlphaNum, isPrint+    , isDigit, isOctDigit, isHexDigit+    , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator++    -- ** Subranges+    , isAscii, isLatin1+    , isAsciiUpper, isAsciiLower++    -- ** Unicode general categories+    , GeneralCategory(..), generalCategory++    -- * Case conversion+    , toUpper, toLower, toTitle  -- :: Char -> Char++    -- * Single digit characters+    , digitToInt        -- :: Char -> Int+    , intToDigit        -- :: Int  -> Char++    -- * Numeric representations+    , ord               -- :: Char -> Int+    , chr               -- :: Int  -> Char++    -- * String representations+    , showLitChar       -- :: Char -> ShowS+    , lexLitChar        -- :: ReadS String+    , readLitChar       -- :: ReadS Char ++     -- Implementation checked wrt. Haskell 98 lib report, 1/99.     ) where ---import Array         -- Used for character name table.-import Numeric (readDec, readOct, lexDigits, readHex)-import Prelude.Text-import Lhc.Basics-import Data.Word(Word())-import Prelude.CType+#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Arr (Ix)+import GHC.Real (fromIntegral)+import GHC.Show+import GHC.Read (Read, readLitChar, lexLitChar)+import GHC.Unicode+import GHC.Num+import GHC.Enum+#endif +#ifdef __HUGS__+import Hugs.Prelude (Ix)+import Hugs.Char+#endif +#ifdef __NHC__+import Prelude+import Prelude(Char,String)+import Char+import Ix+import NHC.FFI (CInt)+foreign import ccall unsafe "WCsubst.h u_gencat" wgencat :: CInt -> CInt+#endif +-- | Convert a single digit 'Char' to the corresponding 'Int'.  +-- This function fails unless its argument satisfies 'isHexDigit',+-- but recognises both upper and lower-case hexadecimal digits+-- (i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).+digitToInt :: Char -> Int+digitToInt c+ | isDigit c            =  ord c - ord '0'+ | c >= 'a' && c <= 'f' =  ord c - ord 'a' + 10+ | c >= 'A' && c <= 'F' =  ord c - ord 'A' + 10+ | otherwise            =  error ("Char.digitToInt: not a digit " ++ show c) -- sigh +#ifndef __GLASGOW_HASKELL__+isAsciiUpper, isAsciiLower :: Char -> Bool+isAsciiLower c          =  c >= 'a' && c <= 'z'+isAsciiUpper c          =  c >= 'A' && c <= 'Z'+#endif --- Text functions-readLitChar          :: ReadS Char-readLitChar ('\\':s) =  readEsc s-readLitChar (c:s)    =  [(c,s)]+-- | Unicode General Categories (column 2 of the UnicodeData table)+-- in the order they are listed in the Unicode standard. -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 ['\NUL' .. ] asciiTab-                   in case [(c,s') | (c, mne) <- table,-                                     ([],s') <- [match mne s]]-                      of (pr:_) -> [pr]-                         []     -> []-readEsc _        = []+data GeneralCategory+        = UppercaseLetter       -- ^ Lu: Letter, Uppercase+        | LowercaseLetter       -- ^ Ll: Letter, Lowercase+        | TitlecaseLetter       -- ^ Lt: Letter, Titlecase+        | ModifierLetter        -- ^ Lm: Letter, Modifier+        | OtherLetter           -- ^ Lo: Letter, Other+        | NonSpacingMark        -- ^ Mn: Mark, Non-Spacing+        | SpacingCombiningMark  -- ^ Mc: Mark, Spacing Combining+        | EnclosingMark         -- ^ Me: Mark, Enclosing+        | DecimalNumber         -- ^ Nd: Number, Decimal+        | LetterNumber          -- ^ Nl: Number, Letter+        | OtherNumber           -- ^ No: Number, Other+        | ConnectorPunctuation  -- ^ Pc: Punctuation, Connector+        | DashPunctuation       -- ^ Pd: Punctuation, Dash+        | OpenPunctuation       -- ^ Ps: Punctuation, Open+        | ClosePunctuation      -- ^ Pe: Punctuation, Close+        | InitialQuote          -- ^ Pi: Punctuation, Initial quote+        | FinalQuote            -- ^ Pf: Punctuation, Final quote+        | OtherPunctuation      -- ^ Po: Punctuation, Other+        | MathSymbol            -- ^ Sm: Symbol, Math+        | CurrencySymbol        -- ^ Sc: Symbol, Currency+        | ModifierSymbol        -- ^ Sk: Symbol, Modifier+        | OtherSymbol           -- ^ So: Symbol, Other+        | Space                 -- ^ Zs: Separator, Space+        | LineSeparator         -- ^ Zl: Separator, Line+        | ParagraphSeparator    -- ^ Zp: Separator, Paragraph+        | Control               -- ^ Cc: Other, Control+        | Format                -- ^ Cf: Other, Format+        | Surrogate             -- ^ Cs: Other, Surrogate+        | PrivateUse            -- ^ Co: Other, Private Use+        | NotAssigned           -- ^ Cn: Other, Not Assigned+        deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix) -match                         :: (Eq a) => [a] -> [a] -> ([a],[a])-match (x:xs) (y:ys) | x == y  =  match xs ys-match xs     ys               =  (xs,ys)+-- | The Unicode general category of the character.+generalCategory :: Char -> GeneralCategory+#if defined(__LHC__)+generalCategory c = NotAssigned+#elif defined(__GLASGOW_HASKELL__) || defined(__NHC__)+generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c+#endif+#ifdef __HUGS__+generalCategory c = toEnum (primUniGenCat c)+#endif -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))+-- derived character classifiers -protectEsc p f             = f . cont-                             where cont s@(c:_) | p c = "\\&" ++ s-                                   cont s             = s+-- | Selects alphabetic Unicode characters (lower-case, upper-case and+-- title-case letters, plus letters of caseless scripts and modifiers letters).+-- This function is equivalent to 'Data.Char.isAlpha'.+isLetter :: Char -> Bool+isLetter c = case generalCategory c of+        UppercaseLetter         -> True+        LowercaseLetter         -> True+        TitlecaseLetter         -> True+        ModifierLetter          -> True+        OtherLetter             -> True+        _                       -> False -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"]+-- | Selects Unicode mark characters, e.g. accents and the like, which+-- combine with preceding letters.+isMark :: Char -> Bool+isMark c = case generalCategory c of+        NonSpacingMark          -> True+        SpacingCombiningMark    -> True+        EnclosingMark           -> True+        _                       -> False++-- | Selects Unicode numeric characters, including digits from various+-- scripts, Roman numerals, etc.+isNumber :: Char -> Bool+isNumber c = case generalCategory c of+        DecimalNumber           -> True+        LetterNumber            -> True+        OtherNumber             -> True+        _                       -> False++-- | Selects Unicode punctuation characters, including various kinds+-- of connectors, brackets and quotes.+isPunctuation :: Char -> Bool+isPunctuation c = case generalCategory c of+        ConnectorPunctuation    -> True+        DashPunctuation         -> True+        OpenPunctuation         -> True+        ClosePunctuation        -> True+        InitialQuote            -> True+        FinalQuote              -> True+        OtherPunctuation        -> True+        _                       -> False++-- | Selects Unicode symbol characters, including mathematical and+-- currency symbols.+isSymbol :: Char -> Bool+isSymbol c = case generalCategory c of+        MathSymbol              -> True+        CurrencySymbol          -> True+        ModifierSymbol          -> True+        OtherSymbol             -> True+        _                       -> False++-- | Selects Unicode space and separator characters.+isSeparator :: Char -> Bool+isSeparator c = case generalCategory c of+        Space                   -> True+        LineSeparator           -> True+        ParagraphSeparator      -> True+        _                       -> False++#ifdef __NHC__+-- dummy implementation+toTitle :: Char -> Char+toTitle = toUpper+#endif
− lib/base/src/Data/Complex.hs 
@@ -1,104 +0,0 @@-module Data.Complex(-    Complex((:+)),-    realPart,-    imagPart,-    conjugate,-    mkPolar,-    cis,-    polar,-    magnitude,-    phase-    )  where--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/base/src/Data/Dynamic.hs view
@@ -1,17 +1,112 @@-{-# OPTIONS_LHC -fffi #-}-module Data.Dynamic(Dynamic,toDyn,fromDyn,fromDynamic,dynApply,dynApp) where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Dynamic+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The Dynamic interface provides basic support for dynamic types.+-- +-- Operations for injecting values of arbitrary type into+-- a dynamically typed value, Dynamic, are provided, together+-- with operations for converting dynamic values into a concrete+-- (monomorphic) type.+-- +----------------------------------------------------------------------------- +module Data.Dynamic+  ( +        -- Module Data.Typeable re-exported for convenience+        module Data.Typeable,++        -- * The @Dynamic@ type+        Dynamic,        -- abstract, instance of: Show, Typeable++        -- * Converting to and from @Dynamic@+        toDyn,          -- :: Typeable a => a -> Dynamic+        fromDyn,        -- :: Typeable a => Dynamic -> a -> a+        fromDynamic,    -- :: Typeable a => Dynamic -> Maybe a+        +        -- * Applying functions of dynamic type+        dynApply,+        dynApp,+        dynTypeRep++  ) where++ import Data.Typeable+import Data.Maybe+import Unsafe.Coerce -data Obj+#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Show+import GHC.Err+import GHC.Num+#endif +#ifdef __HUGS__+import Hugs.Prelude+import Hugs.IO+import Hugs.IORef+import Hugs.IOExts+#endif++#ifdef __NHC__+import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)+#endif++#include "Typeable.h"++-------------------------------------------------------------+--+--              The type Dynamic+--+-------------------------------------------------------------++{-|+  A value of type 'Dynamic' is an object encapsulated together with its type.++  A 'Dynamic' may only represent a monomorphic value; an attempt to+  create a value of type 'Dynamic' from a polymorphically-typed+  expression will result in an ambiguity error (see 'toDyn').++  'Show'ing a value of type 'Dynamic' returns a pretty-printed representation+  of the object\'s type; useful for debugging.+-}+#ifndef __HUGS__ data Dynamic = Dynamic TypeRep Obj+#endif +INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")+ instance Show Dynamic where-    showsPrec _ x s = "<Dynamic>" ++ s+   -- the instance just prints the type representation.+   showsPrec _ (Dynamic t _) = +          showString "<<" . +          showsPrec 0 t   . +          showString ">>" --- | Converts an arbitrary value into an object of type 'Dynamic'.+#ifdef __GLASGOW_HASKELL__+type Obj = Any+ -- Use GHC's primitive 'Any' type to hold the dynamically typed value.+ --+ -- In GHC's new eval/apply execution model this type must not look+ -- like a data type.  If it did, GHC would use the constructor convention + -- when evaluating it, and this will go wrong if the object is really a + -- function.  Using Any forces GHC to use+ -- a fallback convention for evaluating it that works for all types.+#elif !defined(__HUGS__)+data Obj = Obj+#endif++-- | 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@@ -26,11 +121,11 @@ -- | 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.+        => 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@@ -38,13 +133,13 @@ -- | 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.+        :: 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+  case unsafeCoerce v of      r | t == typeOf r -> Just r       | otherwise     -> Nothing @@ -56,11 +151,11 @@     Nothing -> Nothing  dynApp :: Dynamic -> Dynamic -> Dynamic-dynApp f x = case dynApply f x of+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+dynTypeRep :: Dynamic -> TypeRep+dynTypeRep (Dynamic tr _) = tr
+ lib/base/src/Data/Either.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Either+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The Either type, and associated operations.+--+-----------------------------------------------------------------------------++module Data.Either (+   Either(..),+   either,           -- :: (a -> c) -> (b -> c) -> Either a b -> c+   lefts,            -- :: [Either a b] -> [a]+   rights,           -- :: [Either a b] -> [b]+   partitionEithers, -- :: [Either a b] -> ([a],[b])+ ) where++#include "Typeable.h"++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Show+import GHC.Read+#endif++import Data.Typeable++#ifdef __GLASGOW_HASKELL__+{-+-- just for testing+import Test.QuickCheck+-}++{-|++The 'Either' type represents values with two possibilities: a value of+type @'Either' a b@ is either @'Left' a@ or @'Right' b@.++The 'Either' type is sometimes used to represent a value which is+either correct or an error; by convention, the 'Left' constructor is+used to hold an error value and the 'Right' constructor is used to+hold a correct value (mnemonic: \"right\" also means \"correct\").+-}+data  Either a b  =  Left a | Right b   deriving (Eq, Ord, Read, Show)++-- | Case analysis for the 'Either' type.+-- If the value is @'Left' a@, apply the first function to @a@;+-- if it is @'Right' b@, apply the second function to @b@.+either                  :: (a -> c) -> (b -> c) -> Either a b -> c+either f _ (Left x)     =  f x+either _ g (Right y)    =  g y+#endif  /* __GLASGOW_HASKELL__ */++INSTANCE_TYPEABLE2(Either,eitherTc,"Either")++-- | Extracts from a list of 'Either' all the 'Left' elements+-- All the 'Left' elements are extracted in order.++lefts   :: [Either a b] -> [a]+lefts x = [a | Left a <- x]++-- | Extracts from a list of 'Either' all the 'Right' elements+-- All the 'Right' elements are extracted in order.++rights   :: [Either a b] -> [b]+rights x = [a | Right a <- x]++-- | Partitions a list of 'Either' into two lists+-- All the 'Left' elements are extracted, in order, to the first+-- component of the output.  Similarly the 'Right' elements are extracted+-- to the second component of the output.++partitionEithers :: [Either a b] -> ([a],[b])+partitionEithers = foldr (either left right) ([],[])+ where+  left  a (l, r) = (a:l, r)+  right a (l, r) = (l, a:r)++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+prop_partitionEithers :: [Either Int Int] -> Bool+prop_partitionEithers x =+  partitionEithers x == (lefts x, rights x)+-}+
− lib/base/src/Data/Function.hs 
@@ -1,83 +0,0 @@--------------------------------------------------------------------------------- |--- 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 Prelude--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/base/src/Data/HashTable.hs view
@@ -0,0 +1,498 @@+{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.HashTable+-- Copyright   :  (c) The University of Glasgow 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- An implementation of extensible hash tables, as described in+-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,+-- pp. 446--457.  The implementation is also derived from the one+-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).+--+-----------------------------------------------------------------------------++module Data.HashTable (+        -- * Basic hash table operations+        HashTable, new, insert, delete, lookup, update,+        -- * Converting to and from lists+        fromList, toList,+        -- * Hash functions+        -- $hash_functions+        hashInt, hashString,+        prime,+        -- * Diagnostics+        longestChain+ ) where++-- This module is imported by Data.Dynamic, which is pretty low down in the+-- module hierarchy, so don't import "high-level" modules++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#else+import Prelude  hiding  ( lookup )+#endif+import Data.Tuple       ( fst )+import Data.Bits+import Data.Maybe+import Data.List        ( maximumBy, length, concat, foldl', partition )+import Data.Int         ( Int32 )++#if defined(__GLASGOW_HASKELL__)+import GHC.Num+import GHC.Real         ( fromIntegral )+import GHC.Show         ( Show(..) )+import GHC.Int          ( Int64 )++import GHC.IOBase       ( IO, IOArray, newIOArray,+                          unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO,+                          IORef, newIORef, readIORef, writeIORef )+#else+import Data.Char        ( ord )+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )+import System.IO.Unsafe ( unsafePerformIO )+import Data.Int         ( Int64 )+#  if defined(__HUGS__)+import Hugs.IOArray     ( IOArray, newIOArray,+                          unsafeReadIOArray, unsafeWriteIOArray )+#  elif defined(__NHC__)+import NHC.IOExtras     ( IOArray, newIOArray, readIOArray, writeIOArray )+#  endif+#endif+import Control.Monad    ( mapM, mapM_, sequence_ )+++-----------------------------------------------------------------------++iNSTRUMENTED :: Bool+iNSTRUMENTED = False++-----------------------------------------------------------------------++readHTArray  :: HTArray a -> Int32 -> IO a+writeMutArray :: MutArray a -> Int32 -> a -> IO ()+freezeArray  :: MutArray a -> IO (HTArray a)+thawArray    :: HTArray a -> IO (MutArray a)+newMutArray   :: (Int32, Int32) -> a -> IO (MutArray a)+#if defined(DEBUG) || defined(__NHC__)+type MutArray a = IOArray Int32 a+type HTArray a = MutArray a+newMutArray = newIOArray+readHTArray  = readIOArray+writeMutArray = writeIOArray+freezeArray = return+thawArray = return+#else+type MutArray a = IOArray Int32 a+type HTArray a = MutArray a -- Array Int32 a+newMutArray = newIOArray+readHTArray arr i = readMutArray arr i -- return $! (unsafeAt arr (fromIntegral i))+readMutArray  :: MutArray a -> Int32 -> IO a+readMutArray arr i = unsafeReadIOArray arr (fromIntegral i)+writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x+freezeArray = return -- unsafeFreeze+thawArray = return -- unsafeThaw+#endif++data HashTable key val = HashTable {+                                     cmp     :: !(key -> key -> Bool),+                                     hash_fn :: !(key -> Int32),+                                     tab     :: !(IORef (HT key val))+                                   }+-- TODO: the IORef should really be an MVar.++data HT key val+  = HT {+        kcount  :: !Int32,              -- Total number of keys.+        bmask   :: !Int32,+        buckets :: !(HTArray [(key,val)])+       }++-- ------------------------------------------------------------+-- Instrumentation for performance tuning++-- This ought to be roundly ignored after optimization when+-- iNSTRUMENTED=False.++-- STRICT version of modifyIORef!+modifyIORef :: IORef a -> (a -> a) -> IO ()+modifyIORef r f = do+  v <- readIORef r+  let z = f v in z `seq` writeIORef r z++data HashData = HD {+  tables :: !Integer,+  insertions :: !Integer,+  lookups :: !Integer,+  totBuckets :: !Integer,+  maxEntries :: !Int32,+  maxChain :: !Int,+  maxBuckets :: !Int32+} deriving (Eq, Show)++{-# NOINLINE hashData #-}+hashData :: IORef HashData+hashData =  unsafePerformIO (newIORef (HD { tables=0, insertions=0, lookups=0,+                                            totBuckets=0, maxEntries=0,+                                            maxChain=0, maxBuckets=tABLE_MIN } ))++instrument :: (HashData -> HashData) -> IO ()+instrument i | iNSTRUMENTED = modifyIORef hashData i+             | otherwise    = return ()++recordNew :: IO ()+recordNew = instrument rec+  where rec hd@HD{ tables=t, totBuckets=b } =+               hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN }++recordIns :: Int32 -> Int32 -> [a] -> IO ()+recordIns i sz bkt = instrument rec+  where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } =+               hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz,+                   maxChain=mc `max` length bkt }++recordResize :: Int32 -> Int32 -> IO ()+recordResize older newer = instrument rec+  where rec hd@HD{ totBuckets=b, maxBuckets=mx } =+               hd{ totBuckets=b+fromIntegral (newer-older),+                   maxBuckets=mx `max` newer }++recordLookup :: IO ()+recordLookup = instrument lkup+  where lkup hd@HD{ lookups=l } = hd{ lookups=l+1 }++-- stats :: IO String+-- stats =  fmap show $ readIORef hashData++-- ----------------------------------------------------------------------------+-- Sample hash functions++-- $hash_functions+--+-- This implementation of hash tables uses the low-order /n/ bits of the hash+-- value for a key, where /n/ varies as the hash table grows.  A good hash+-- function therefore will give an even distribution regardless of /n/.+--+-- If your keyspace is integrals such that the low-order bits between+-- keys are highly variable, then you could get away with using 'fromIntegral'+-- as the hash function.+--+-- We provide some sample hash functions for 'Int' and 'String' below.++golden :: Int32+golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32+-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32+-- but that has bad mulHi properties (even adding 2^32 to get its inverse)+-- Whereas the above works well and contains no hash duplications for+-- [-32767..65536]++hashInt32 :: Int32 -> Int32+hashInt32 x = mulHi x golden + x++-- | A sample (and useful) hash function for Int and Int32,+-- implemented by extracting the uppermost 32 bits of the 64-bit+-- result of multiplying by a 33-bit constant.  The constant is from+-- Knuth, derived from the golden ratio:+--+-- > golden = round ((sqrt 5 - 1) * 2^32)+--+-- We get good key uniqueness on small inputs+-- (a problem with previous versions):+--  (length $ group $ sort $ map hashInt [-32767..65536]) == 65536 + 32768+--+hashInt :: Int -> Int32+hashInt x = hashInt32 (fromIntegral x)++-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply+mulHi :: Int32 -> Int32 -> Int32+mulHi a b = fromIntegral (r `shiftR` 32)+   where r :: Int64+         r = fromIntegral a * fromIntegral b++-- | A sample hash function for Strings.  We keep multiplying by the+-- golden ratio and adding.  The implementation is:+--+-- > hashString = foldl' f golden+-- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m+-- >         magic = 0xdeadbeef+--+-- Where hashInt32 works just as hashInt shown above.+--+-- Knuth argues that repeated multiplication by the golden ratio+-- will minimize gaps in the hash space, and thus it's a good choice+-- for combining together multiple keys to form one.+--+-- Here we know that individual characters c are often small, and this+-- produces frequent collisions if we use ord c alone.  A+-- particular problem are the shorter low ASCII and ISO-8859-1+-- character strings.  We pre-multiply by a magic twiddle factor to+-- obtain a good distribution.  In fact, given the following test:+--+-- > testp :: Int32 -> Int+-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls+-- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]+-- >         hs = foldl' f golden+-- >         f m c = fromIntegral (ord c) * k + hashInt32 m+-- >         n = 100000+--+-- We discover that testp magic = 0.++hashString :: String -> Int32+hashString = foldl' f golden+   where f m c = fromIntegral (ord c) * magic + hashInt32 m+         magic = 0xdeadbeef++-- | A prime larger than the maximum hash table size+prime :: Int32+prime = 33554467++-- -----------------------------------------------------------------------------+-- Parameters++tABLE_MAX :: Int32+tABLE_MAX  = 32 * 1024 * 1024   -- Maximum size of hash table+tABLE_MIN :: Int32+tABLE_MIN  = 8++hLOAD :: Int32+hLOAD = 7                       -- Maximum average load of a single hash bucket++hYSTERESIS :: Int32+hYSTERESIS = 64                 -- entries to ignore in load computation++{- Hysteresis favors long association-list-like behavior for small tables. -}++-- -----------------------------------------------------------------------------+-- Creating a new hash table++-- | Creates a new hash table.  The following property should hold for the @eq@+-- and @hash@ functions passed to 'new':+--+-- >   eq A B  =>  hash A == hash B+--+new+  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys+  -> (key -> Int32)          -- ^ @hash@: A hash function on keys+  -> IO (HashTable key val)  -- ^ Returns: an empty hash table++new cmpr hash = do+  recordNew+  -- make a new hash table with a single, empty, segment+  let mask = tABLE_MIN-1+  bkts'  <- newMutArray (0,mask) []+  bkts   <- freezeArray bkts'++  let+    kcnt = 0+    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask }++  table <- newIORef ht+  return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })++-- -----------------------------------------------------------------------------+-- Inserting a key\/value pair into the hash table++-- | Inserts a key\/value mapping into the hash table.+--+-- Note that 'insert' doesn't remove the old entry from the table -+-- the behaviour is like an association list, where 'lookup' returns+-- the most-recently-inserted mapping for a key in the table.  The+-- reason for this is to keep 'insert' as efficient as possible.  If+-- you need to update a mapping, then we provide 'update'.+--+insert :: HashTable key val -> key -> val -> IO ()++insert ht key val =+  updatingBucket CanInsert (\bucket -> ((key,val):bucket, 1, ())) ht key+++-- ------------------------------------------------------------+-- The core of the implementation is lurking down here, in findBucket,+-- updatingBucket, and expandHashTable.++tooBig :: Int32 -> Int32 -> Bool+tooBig k b = k-hYSTERESIS > hLOAD * b++-- index of bucket within table.+bucketIndex :: Int32 -> Int32 -> Int32+bucketIndex mask h = h .&. mask++-- find the bucket in which the key belongs.+-- returns (key equality, bucket index, bucket)+--+-- This rather grab-bag approach gives enough power to do pretty much+-- any bucket-finding thing you might want to do.  We rely on inlining+-- to throw away the stuff we don't want.  I'm proud to say that this+-- plus updatingBucket below reduce most of the other definitions to a+-- few lines of code, while actually speeding up the hashtable+-- implementation when compared with a version which does everything+-- from scratch.+{-# INLINE findBucket #-}+findBucket :: HashTable key val -> key -> IO (HT key val, Int32, [(key,val)])+findBucket HashTable{ tab=ref, hash_fn=hash} key = do+  table@HT{ buckets=bkts, bmask=b } <- readIORef ref+  let indx = bucketIndex b (hash key)+  bucket <- readHTArray bkts indx+  return (table, indx, bucket)++data Inserts = CanInsert+             | Can'tInsert+             deriving (Eq)++-- updatingBucket is the real workhorse of all single-element table+-- updates.  It takes a hashtable and a key, along with a function+-- describing what to do with the bucket in which that key belongs.  A+-- flag indicates whether this function may perform table insertions.+-- The function returns the new contents of the bucket, the number of+-- bucket entries inserted (negative if entries were deleted), and a+-- value which becomes the return value for the function as a whole.+-- The table sizing is enforced here, calling out to expandSubTable as+-- necessary.++-- This function is intended to be inlined and specialized for every+-- calling context (eg every provided bucketFn).+{-# INLINE updatingBucket #-}++updatingBucket :: Inserts -> ([(key,val)] -> ([(key,val)], Int32, a)) ->+                  HashTable key val -> key ->+                  IO a+updatingBucket canEnlarge bucketFn+               ht@HashTable{ tab=ref, hash_fn=hash } key = do+  (table@HT{ kcount=k, buckets=bkts, bmask=b },+   indx, bckt) <- findBucket ht key+  (bckt', inserts, result) <- return $ bucketFn bckt+  let k' = k + inserts+      table1 = table { kcount=k' }+  bkts' <- thawArray bkts+  writeMutArray bkts' indx bckt'+  freezeArray bkts'+  table2 <- if canEnlarge == CanInsert && inserts > 0 then do+               recordIns inserts k' bckt'+               if tooBig k' b+                  then expandHashTable hash table1+                  else return table1+            else return table1+  writeIORef ref table2+  return result++expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val)+expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do+   let+      oldsize = mask + 1+      newmask = mask + mask + 1+   recordResize oldsize (newmask+1)+   --+   if newmask > tABLE_MAX-1+      then return table+      else do+   --+    newbkts' <- newMutArray (0,newmask) []++    let+     splitBucket oldindex = do+       bucket <- readHTArray bkts oldindex+       let (oldb,newb) =+              partition ((oldindex==). bucketIndex newmask . hash . fst) bucket+       writeMutArray newbkts' oldindex oldb+       writeMutArray newbkts' (oldindex + oldsize) newb+    mapM_ splitBucket [0..mask]++    newbkts <- freezeArray newbkts'++    return ( table{ buckets=newbkts, bmask=newmask } )++-- -----------------------------------------------------------------------------+-- Deleting a mapping from the hash table++-- Remove a key from a bucket+deleteBucket :: (key -> Bool) -> [(key,val)] -> ([(key, val)], Int32, ())+deleteBucket _   [] = ([],0,())+deleteBucket del (pair@(k,_):bucket) =+  case deleteBucket del bucket of+    (bucket', dels, _) | del k     -> dels' `seq` (bucket', dels', ())+                       | otherwise -> (pair:bucket', dels, ())+      where dels' = dels - 1++-- | Remove an entry from the hash table.+delete :: HashTable key val -> key -> IO ()++delete ht@HashTable{ cmp=eq } key =+  updatingBucket Can'tInsert (deleteBucket (eq key)) ht key++-- -----------------------------------------------------------------------------+-- Updating a mapping in the hash table++-- | Updates an entry in the hash table, returning 'True' if there was+-- already an entry for this key, or 'False' otherwise.  After 'update'+-- there will always be exactly one entry for the given key in the table.+--+-- 'insert' is more efficient than 'update' if you don't care about+-- multiple entries, or you know for sure that multiple entries can't+-- occur.  However, 'update' is more efficient than 'delete' followed+-- by 'insert'.+update :: HashTable key val -> key -> val -> IO Bool++update ht@HashTable{ cmp=eq } key val =+  updatingBucket CanInsert+    (\bucket -> let (bucket', dels, _) = deleteBucket (eq key) bucket+                in  ((key,val):bucket', 1+dels, dels/=0))+    ht key++-- -----------------------------------------------------------------------------+-- Looking up an entry in the hash table++-- | Looks up the value of a key in the hash table.+lookup :: HashTable key val -> key -> IO (Maybe val)++lookup ht@HashTable{ cmp=eq } key = do+  recordLookup+  (_, _, bucket) <- findBucket ht key+  let firstHit (k,v) r | eq key k  = Just v+                       | otherwise = r+  return (foldr firstHit Nothing bucket)++-- -----------------------------------------------------------------------------+-- Converting to/from lists++-- | Convert a list of key\/value pairs into a hash table.  Equality on keys+-- is taken from the Eq instance for the key type.+--+fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)+fromList hash list = do+  table <- new (==) hash+  sequence_ [ insert table k v | (k,v) <- list ]+  return table++-- | Converts a hash table to a list of key\/value pairs.+--+toList :: HashTable key val -> IO [(key,val)]+toList = mapReduce id concat++{-# INLINE mapReduce #-}+mapReduce :: ([(key,val)] -> r) -> ([r] -> r) -> HashTable key val -> IO r+mapReduce m r HashTable{ tab=ref } = do+  HT{ buckets=bckts, bmask=b } <- readIORef ref+  fmap r (mapM (fmap m . readHTArray bckts) [0..b])++-- -----------------------------------------------------------------------------+-- Diagnostics++-- | This function is useful for determining whether your hash+-- function is working well for your data set.  It returns the longest+-- chain of key\/value pairs in the hash table for which all the keys+-- hash to the same bucket.  If this chain is particularly long (say,+-- longer than 14 elements or so), then it might be a good idea to try+-- a different hash function.+--+longestChain :: HashTable key val -> IO [(key,val)]+longestChain = mapReduce id (maximumBy lengthCmp)+  where lengthCmp (_:x)(_:y) = lengthCmp x y+        lengthCmp []   []    = EQ+        lengthCmp []   _     = LT+        lengthCmp _    []    = GT
lib/base/src/Data/IORef.hs view
@@ -1,77 +1,92 @@-{-# OPTIONS_LHC -N -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 Lhc.Basics-import Lhc.Order-import Lhc.IO-import Lhc.Int--data IORef a = IORef (Ref__ a)-data Ref__ a :: #---foreign import primitive newRef__   :: a -> UIO (Ref__ a)-foreign import primitive readRef__  :: Ref__ a -> UIO a-foreign import primitive writeRef__ :: Ref__ a -> a -> UIO_---- {-# NOINLINE newIORef #-}-newIORef :: a -> IO (IORef a)-newIORef v = IO $ \w -> case newRef__ v w of (# w', r #) -> (# w', IORef r #)+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IORef+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Mutable references in the IO monad.+--+----------------------------------------------------------------------------- +module Data.IORef+  ( +        -- * IORefs+        IORef,                -- abstract, instance of: Eq, Typeable+        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 --- {-# NOINLINE readIORef #-}-readIORef :: IORef a -> IO a-readIORef (IORef r) = IO $ \w -> readRef__ r w+#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__) && !defined(__LHC__)+        mkWeakIORef,          -- :: IORef a -> IO () -> IO (Weak (IORef a))+#endif+        ) where --- {-# NOINLINE writeIORef #-}-writeIORef :: IORef a -> a -> IO ()-writeIORef (IORef r) v = IO $ \w -> case writeRef__ r v w of w' -> (# w', () #)+#ifdef __HUGS__+import Hugs.IORef+#endif ---foreign import primitive eqRef__ :: Ref__ a -> Ref__ a -> Bool+#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.STRef+import GHC.IOBase+#if !defined(__PARALLEL_HASKELL__) && !defined(__LHC__)+import GHC.Weak+#endif+#endif /* __GLASGOW_HASKELL__ */ ---instance Eq (IORef a) where---    (IORef x) == (IORef y) = eqRef__ x y+#ifdef __NHC__+import NHC.IOExtras+    ( IORef+    , newIORef+    , readIORef+    , writeIORef+    , excludeFinalisers+    )+#endif +#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__) && !defined(__LHC__)+-- |Make a 'Weak' pointer to an 'IORef'+mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))+mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->+  case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)+#endif ---{-# NOINLINE modifyIORef #-}+-- |Mutate the contents of an 'IORef' modifyIORef :: IORef a -> (a -> a) -> IO ()-modifyIORef (IORef ref) f = IO $ \w -> case readRef__ ref w of-    (# w', a #) -> case writeRef__ ref (f a) w' of-        w'' -> (# w'', () #)+modifyIORef ref f = readIORef ref >>= writeIORef ref . f ---{-# NOINLINE atomicModifyIORef #-}-atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORef (IORef r) f = IO $ \w -> case readRef__ r w of-    (# w', a #) -> case f a of-        (a',b) -> case writeRef__ r a' w' of-            w'' -> (# w'', b #)-{----newIORef v = IO $ \_ world -> case newRef__ v world of---    (world',r) -> JustIO world' r---readIORef r = IO $ \_ world -> case readRef__ r world of---    (world',v) -> JustIO world' v---writeIORef r v = IO $ \_ world -> case writeRef__ r v world of---    world' -> JustIO world' ()-{-# NOINLINE newIORef #-}-newIORef :: a -> IO (IORef a)-newIORef v = do-    v' <- strictReturn v-    return (IORef v') -{-# NOINLINE readIORef #-}-readIORef :: IORef a -> IO a-readIORef r = do-    --v <- strictReturn r-    case r of-        IORef r -> strictReturn r--}+-- |Atomically modifies the contents of an 'IORef'.+--+-- This function is useful for using 'IORef' in a safe way in a multithreaded+-- program.  If you only have one 'IORef', then using 'atomicModifyIORef' to+-- access and modify it will prevent race conditions.+--+-- Extending the atomicity to multiple 'IORef's is problematic, so it+-- is recommended that if you need to do anything more complicated+-- then using 'Control.Concurrent.MVar.MVar' instead is a good idea.+--+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b+#if defined(__GLASGOW_HASKELL__)+atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s ---foreign import primitive newRef__ :: forall s . a -> s -> (s,Ref s a)---foreign import primitive readRef__ :: forall s . Ref s a -> s -> (s,a)+#elif defined(__HUGS__)+atomicModifyIORef = plainModifyIORef    -- Hugs has no preemption+  where plainModifyIORef r f = do+                a <- readIORef r+                case f a of (a',b) -> writeIORef r a' >> return b+#elif defined(__NHC__)+atomicModifyIORef r f =+  excludeFinalisers $ do+    a <- readIORef r+    let (a',b) = f a+    writeIORef r a'+    return b+#endif
lib/base/src/Data/Int.hs view
@@ -1,5 +1,65 @@-{-# OPTIONS_LHC -N #-}-module Data.Int(Int,Int8,Int16,Int32,Int64,IntMax,IntPtr) where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Int+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Signed integer types+--+----------------------------------------------------------------------------- -import Lhc.Prim+module Data.Int+  ( +        -- * Signed integer types+        Int,+        Int8, Int16, Int32, Int64, +        -- * Notes++        -- $notes+        ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base ( Int )+import GHC.Int  ( Int8, Int16, Int32, Int64 )+#endif++#ifdef __HUGS__+import Hugs.Int ( Int8, Int16, Int32, Int64 )+#endif++#ifdef __NHC__+import Prelude+import Prelude (Int)+import NHC.FFI (Int8, Int16, Int32, Int64)+import NHC.SizedTypes (Int8, Int16, Int32, Int64)       -- instances of Bits+#endif++{- $notes++* All arithmetic is performed modulo 2^n, where @n@ is the number of+  bits in the type.++* For coercing between any two integer types, use 'Prelude.fromIntegral',+  which is specialized for all the common cases so should be fast+  enough.  Coercing word types (see "Data.Word") to and from integer+  types preserves representation, not sign.++* The rules that hold for 'Prelude.Enum' instances over a+  bounded type such as 'Int' (see the section of the+  Haskell report dealing with arithmetic sequences) also hold for the+  'Prelude.Enum' instances over the various+  'Int' types defined here.++* Right and left shifts by amounts greater than or equal to the width+  of the type result in either zero or -1, depending on the sign of+  the value being shifted.  This is contrary to the behaviour in C,+  which is undefined; a common interpretation is to truncate the shift+  count to the width of the type, for example @1 \<\< 32+  == 1@ in some C implementations.+-}
lib/base/src/Data/Ix.hs view
@@ -1,69 +1,76 @@-{-# OPTIONS_LHC -N #-}-module Data.Ix ( Ix(range, index, inRange, rangeSize) ) where--import Lhc.Int-import Lhc.Enum-import Lhc.Order-import Lhc.Basics-import Lhc.Num-import Lhc.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+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Ix+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The 'Ix' class is used to map a contiguous subrange of values in+-- type onto integers.  It is used primarily for array indexing+-- (see the array package).+-- +-----------------------------------------------------------------------------+module Data.Ix+    (+    -- * The 'Ix' class+        Ix+          ( range       -- :: (Ix a) => (a,a) -> [a]+          , index       -- :: (Ix a) => (a,a) -> a   -> Int+          , inRange     -- :: (Ix a) => (a,a) -> a   -> Bool+          , rangeSize   -- :: (Ix a) => (a,a) -> Int+          )+    -- Ix instances:+    --+    --  Ix Char+    --  Ix Int+    --  Ix Integer+    --  Ix Bool+    --  Ix Ordering+    --  Ix ()+    --  (Ix a, Ix b) => Ix (a, b)+    --  ... -    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)) = []+    -- Implementation checked wrt. Haskell 98 lib report, 1/99. -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'+    -- * Deriving Instances of 'Ix'+    -- | Derived instance declarations for the class 'Ix' are only possible+    -- for enumerations (i.e. datatypes having only nullary constructors)+    -- and single-constructor datatypes, including arbitrarily large tuples,+    -- whose constituent types are instances of 'Ix'. +    -- +    -- * For an enumeration, the nullary constructors are assumed to be+    -- numbered left-to-right with the indices being 0 to n-1 inclusive. This+    -- is the same numbering defined by the 'Enum' class. For example, given+    -- the datatype: +    -- +    -- >        data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet+    -- +    -- we would have: +    -- +    -- >        range   (Yellow,Blue)        ==  [Yellow,Green,Blue]+    -- >        index   (Yellow,Blue) Green  ==  1+    -- >        inRange (Yellow,Blue) Red    ==  False+    -- +    -- * For single-constructor datatypes, the derived instance declarations+    -- are as shown for tuples in Figure 1+    -- <http://www.haskell.org/onlinelibrary/ix.html#prelude-index>. -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+    ) where -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'+import Prelude ---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+#ifdef __GLASGOW_HASKELL__+import GHC.Arr+#endif -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'+#ifdef __HUGS__+import Hugs.Prelude( Ix(..) )+#endif -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'+#ifdef __NHC__+import Ix (Ix(..))+#endif --- 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/base/src/Data/List.hs view
@@ -1,336 +1,1023 @@--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"---+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.List+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Operations on lists.+--+-----------------------------------------------------------------------------++module Data.List+   (+#ifdef __NHC__+     [] (..)+   ,+#endif++   -- * Basic functions++     (++)              -- :: [a] -> [a] -> [a]+   , head              -- :: [a] -> a+   , last              -- :: [a] -> a+   , tail              -- :: [a] -> [a]+   , init              -- :: [a] -> [a]+   , null              -- :: [a] -> Bool+   , length            -- :: [a] -> Int++   -- * List transformations+   , map               -- :: (a -> b) -> [a] -> [b]+   , reverse           -- :: [a] -> [a]++   , intersperse       -- :: a -> [a] -> [a]+   , intercalate       -- :: [a] -> [[a]] -> [a]+   , transpose         -- :: [[a]] -> [[a]]+   +   , subsequences      -- :: [a] -> [[a]]+   , permutations      -- :: [a] -> [[a]]++   -- * Reducing lists (folds)++   , foldl             -- :: (a -> b -> a) -> a -> [b] -> a+   , foldl'            -- :: (a -> b -> a) -> a -> [b] -> a+   , foldl1            -- :: (a -> a -> a) -> [a] -> a+   , foldl1'           -- :: (a -> a -> a) -> [a] -> a+   , foldr             -- :: (a -> b -> b) -> b -> [a] -> b+   , foldr1            -- :: (a -> a -> a) -> [a] -> a++   -- ** Special folds++   , concat            -- :: [[a]] -> [a]+   , concatMap         -- :: (a -> [b]) -> [a] -> [b]+   , and               -- :: [Bool] -> Bool+   , or                -- :: [Bool] -> Bool+   , any               -- :: (a -> Bool) -> [a] -> Bool+   , all               -- :: (a -> Bool) -> [a] -> Bool+   , sum               -- :: (Num a) => [a] -> a+   , product           -- :: (Num a) => [a] -> a+   , maximum           -- :: (Ord a) => [a] -> a+   , minimum           -- :: (Ord a) => [a] -> a++   -- * Building lists++   -- ** Scans+   , scanl             -- :: (a -> b -> a) -> a -> [b] -> [a]+   , scanl1            -- :: (a -> a -> a) -> [a] -> [a]+   , scanr             -- :: (a -> b -> b) -> b -> [a] -> [b]+   , scanr1            -- :: (a -> a -> a) -> [a] -> [a]++   -- ** Accumulating maps+   , mapAccumL         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])+   , mapAccumR         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])++   -- ** Infinite lists+   , iterate           -- :: (a -> a) -> a -> [a]+   , repeat            -- :: a -> [a]+   , replicate         -- :: Int -> a -> [a]+   , cycle             -- :: [a] -> [a]++   -- ** Unfolding+   , unfoldr           -- :: (b -> Maybe (a, b)) -> b -> [a]++   -- * Sublists++   -- ** Extracting sublists+   , take              -- :: Int -> [a] -> [a]+   , drop              -- :: Int -> [a] -> [a]+   , splitAt           -- :: Int -> [a] -> ([a], [a])++   , takeWhile         -- :: (a -> Bool) -> [a] -> [a]+   , dropWhile         -- :: (a -> Bool) -> [a] -> [a]+   , span              -- :: (a -> Bool) -> [a] -> ([a], [a])+   , break             -- :: (a -> Bool) -> [a] -> ([a], [a])++   , stripPrefix       -- :: Eq a => [a] -> [a] -> Maybe [a]++   , group             -- :: Eq a => [a] -> [[a]]++   , inits             -- :: [a] -> [[a]]+   , tails             -- :: [a] -> [[a]]++   -- ** Predicates+   , isPrefixOf        -- :: (Eq a) => [a] -> [a] -> Bool+   , isSuffixOf        -- :: (Eq a) => [a] -> [a] -> Bool+   , isInfixOf         -- :: (Eq a) => [a] -> [a] -> Bool++   -- * Searching lists++   -- ** Searching by equality+   , elem              -- :: a -> [a] -> Bool+   , notElem           -- :: a -> [a] -> Bool+   , lookup            -- :: (Eq a) => a -> [(a,b)] -> Maybe b++   -- ** Searching with a predicate+   , find              -- :: (a -> Bool) -> [a] -> Maybe a+   , filter            -- :: (a -> Bool) -> [a] -> [a]+   , partition         -- :: (a -> Bool) -> [a] -> ([a], [a])++   -- * Indexing lists+   -- | These functions treat a list @xs@ as a indexed collection,+   -- with indices ranging from 0 to @'length' xs - 1@.++   , (!!)              -- :: [a] -> Int -> a++   , elemIndex         -- :: (Eq a) => a -> [a] -> Maybe Int+   , elemIndices       -- :: (Eq a) => a -> [a] -> [Int]++   , findIndex         -- :: (a -> Bool) -> [a] -> Maybe Int+   , findIndices       -- :: (a -> Bool) -> [a] -> [Int]++   -- * Zipping and unzipping lists++   , zip               -- :: [a] -> [b] -> [(a,b)]+   , zip3+   , zip4, zip5, zip6, zip7++   , zipWith           -- :: (a -> b -> c) -> [a] -> [b] -> [c]+   , zipWith3+   , zipWith4, zipWith5, zipWith6, zipWith7++   , unzip             -- :: [(a,b)] -> ([a],[b])+   , unzip3+   , unzip4, unzip5, unzip6, unzip7++   -- * Special lists++   -- ** Functions on strings+   , lines             -- :: String   -> [String]+   , words             -- :: String   -> [String]+   , unlines           -- :: [String] -> String+   , unwords           -- :: [String] -> String++   -- ** \"Set\" operations++   , nub               -- :: (Eq a) => [a] -> [a]++   , delete            -- :: (Eq a) => a -> [a] -> [a]+   , (\\)              -- :: (Eq a) => [a] -> [a] -> [a]++   , union             -- :: (Eq a) => [a] -> [a] -> [a]+   , intersect         -- :: (Eq a) => [a] -> [a] -> [a]++   -- ** Ordered lists+   , sort              -- :: (Ord a) => [a] -> [a]+   , insert            -- :: (Ord a) => a -> [a] -> [a]++   -- * Generalized functions++   -- ** The \"@By@\" operations+   -- | By convention, overloaded functions have a non-overloaded+   -- counterpart whose name is suffixed with \`@By@\'.+   --+   -- It is often convenient to use these functions together with+   -- 'Data.Function.on', for instance @'sortBy' ('compare'+   -- \`on\` 'fst')@.++   -- *** User-supplied equality (replacing an @Eq@ context)+   -- | The predicate is assumed to define an equivalence.+   , nubBy             -- :: (a -> a -> Bool) -> [a] -> [a]+   , deleteBy          -- :: (a -> a -> Bool) -> a -> [a] -> [a]+   , deleteFirstsBy    -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]+   , unionBy           -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]+   , intersectBy       -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]+   , groupBy           -- :: (a -> a -> Bool) -> [a] -> [[a]]++   -- *** User-supplied comparison (replacing an @Ord@ context)+   -- | The function is assumed to define a total ordering.+   , sortBy            -- :: (a -> a -> Ordering) -> [a] -> [a]+   , insertBy          -- :: (a -> a -> Ordering) -> a -> [a] -> [a]+   , maximumBy         -- :: (a -> a -> Ordering) -> [a] -> a+   , minimumBy         -- :: (a -> a -> Ordering) -> [a] -> a++   -- ** The \"@generic@\" operations+   -- | The prefix \`@generic@\' indicates an overloaded function that+   -- is a generalized version of a "Prelude" function.++   , genericLength     -- :: (Integral a) => [b] -> a+   , genericTake       -- :: (Integral a) => a -> [b] -> [b]+   , genericDrop       -- :: (Integral a) => a -> [b] -> [b]+   , genericSplitAt    -- :: (Integral a) => a -> [b] -> ([b], [b])+   , genericIndex      -- :: (Integral a) => [b] -> a -> b+   , genericReplicate  -- :: (Integral a) => a -> b -> [b]++   ) where++#ifdef __NHC__+import Prelude+#endif++import Data.Maybe+import Data.Char        ( isSpace )++#ifdef __GLASGOW_HASKELL__+import GHC.Num+import GHC.Real+import GHC.List+import GHC.Base+#endif++infix 5 \\ -- comment to fool cpp++-- -----------------------------------------------------------------------------+-- List functions++-- | The 'stripPrefix' function drops the given prefix from a list.+-- It returns 'Nothing' if the list did not start with the prefix+-- given, or 'Just' the list after the prefix, if it does.+--+-- > stripPrefix "foo" "foobar" -> Just "bar"+-- > stripPrefix "foo" "foo" -> Just ""+-- > stripPrefix "foo" "barfoo" -> Nothing+-- > stripPrefix "foo" "barfoobaz" -> Nothing+stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]+stripPrefix [] ys = Just ys+stripPrefix (x:xs) (y:ys)+ | x == y = stripPrefix xs ys+stripPrefix _ _ = Nothing++-- | The 'elemIndex' function returns the index of the first element+-- in the given list which is equal (by '==') to the query element,+-- or 'Nothing' if there is no such element.+elemIndex       :: Eq a => a -> [a] -> Maybe Int+elemIndex x     = findIndex (x==)++-- | The 'elemIndices' function extends 'elemIndex', by returning the+-- indices of all elements equal to the query element, in ascending order.+elemIndices     :: Eq a => a -> [a] -> [Int]+elemIndices x   = findIndices (x==)++-- | The 'find' function takes a predicate and a list and returns the+-- first element in the list matching the predicate, or 'Nothing' if+-- there is no such element.+find            :: (a -> Bool) -> [a] -> Maybe a+find p          = listToMaybe . filter p++-- | The 'findIndex' function takes a predicate and a list and returns+-- the index of the first element in the list satisfying the predicate,+-- or 'Nothing' if there is no such element.+findIndex       :: (a -> Bool) -> [a] -> Maybe Int+findIndex p     = listToMaybe . findIndices p++-- | The 'findIndices' function extends 'findIndex', by returning the+-- indices of all elements satisfying the predicate, in ascending order.+findIndices      :: (a -> Bool) -> [a] -> [Int]++#if defined(USE_REPORT_PRELUDE) || !defined(__GLASGOW_HASKELL__)+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]+#else+-- Efficient definition+findIndices p ls = loop 0# ls+                 where+                   loop _ [] = []+                   loop n (x:xs) | p x       = I# n : loop (n +# 1#) xs+                                 | otherwise = loop (n +# 1#) xs+#endif  /* USE_REPORT_PRELUDE */++-- | The 'isPrefixOf' function takes two lists and returns 'True'+-- iff the first list is a prefix of the second.+isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool+isPrefixOf [] _         =  True+isPrefixOf _  []        =  False+isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys++-- | The 'isSuffixOf' function takes two lists and returns 'True'+-- iff the first list is a suffix of the second.+-- Both lists must be finite.+isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++-- | The 'isInfixOf' function takes two lists and returns 'True'+-- iff the first list is contained, wholly and intact,+-- anywhere within the second.+--+-- Example:+--+-- >isInfixOf "Haskell" "I really like Haskell." -> True+-- >isInfixOf "Ial" "I really like Haskell." -> False+isInfixOf               :: (Eq a) => [a] -> [a] -> Bool+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)++-- | The 'nub' function removes duplicate elements from a list.+-- In particular, it keeps only the first occurrence of each element.+-- (The name 'nub' means \`essence\'.)+-- It is a special case of 'nubBy', which allows the programmer to supply+-- their own equality test.+nub                     :: (Eq a) => [a] -> [a]+#ifdef USE_REPORT_PRELUDE+nub                     =  nubBy (==)+#else+-- stolen from HBC+nub l                   = nub' l []             -- '+  where+    nub' [] _           = []                    -- '+    nub' (x:xs) ls                              -- '+        | x `elem` ls   = nub' xs ls            -- '+        | otherwise     = x : nub' xs (x:ls)    -- '+#endif++-- | The 'nubBy' function behaves just like 'nub', except it uses a+-- user-supplied equality predicate instead of the overloaded '=='+-- function.+nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+#ifdef USE_REPORT_PRELUDE+nubBy eq []             =  []+nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs)+#else+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)++-- Not exported:+-- Note that we keep the call to `eq` with arguments in the+-- same order as in the reference implementation+-- 'xs' is the list of things we've seen so far, +-- 'y' is the potential new element+elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool+elem_by _  _ []         =  False+elem_by eq y (x:xs)     =  y `eq` x || elem_by eq y xs+#endif+++-- | 'delete' @x@ removes the first occurrence of @x@ from its list argument.+-- For example,+--+-- > delete 'a' "banana" == "bnana"+--+-- It is a special case of 'deleteBy', which allows the programmer to+-- supply their own equality test.++delete                  :: (Eq a) => a -> [a] -> [a]+delete                  =  deleteBy (==)++-- | The 'deleteBy' function behaves like 'delete', but takes a+-- user-supplied equality predicate.+deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy _  _ []        = []+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++-- | The '\\' function is list difference ((non-associative).+-- In the result of @xs@ '\\' @ys@, the first occurrence of each element of+-- @ys@ in turn (if any) has been removed from @xs@.  Thus+--+-- > (xs ++ ys) \\ xs == ys.+--+-- It is a special case of 'deleteFirstsBy', which allows the programmer+-- to supply their own equality test.++(\\)                    :: (Eq a) => [a] -> [a] -> [a]+(\\)                    =  foldl (flip delete)++-- | The 'union' function returns the list union of the two lists.+-- For example,+--+-- > "dog" `union` "cow" == "dogcw"+--+-- Duplicates, and elements of the first list, are removed from the+-- the second list, but if the first list contains duplicates, so will+-- the result.+-- It is a special case of 'unionBy', which allows the programmer to supply+-- their own equality test.++union                   :: (Eq a) => [a] -> [a] -> [a]+union                   = unionBy (==)++-- | The 'unionBy' function is the non-overloaded version of 'union'.+unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs++-- | The 'intersect' function takes the list intersection of two lists.+-- For example,+--+-- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4]+--+-- If the first list contains duplicates, so will the result.+-- It is a special case of 'intersectBy', which allows the programmer to+-- supply their own equality test.++intersect               :: (Eq a) => [a] -> [a] -> [a]+intersect               =  intersectBy (==)++-- | The 'intersectBy' function is the non-overloaded version of 'intersect'.+intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]++-- | The 'intersperse' function takes an element and a list and+-- \`intersperses\' that element between the elements of the list.+-- For example,+--+-- > intersperse ',' "abcde" == "a,b,c,d,e"++intersperse             :: a -> [a] -> [a]+intersperse _   []      = []+intersperse _   [x]     = [x]+intersperse sep (x:xs)  = x : sep : intersperse sep xs++-- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@.+-- It inserts the list @xs@ in between the lists in @xss@ and concatenates the+-- result.+intercalate :: [a] -> [[a]] -> [a]+intercalate xs xss = concat (intersperse xs xss)++-- | The 'transpose' function transposes the rows and columns of its argument.+-- For example,+--+-- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]]++transpose               :: [[a]] -> [[a]]+transpose []             = []+transpose ([]   : xss)   = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss])+++-- | The 'partition' function takes a predicate a list and returns+-- the pair of lists of elements which do and do not satisfy the+-- predicate, respectively; i.e.,+--+-- > partition p xs == (filter p xs, filter (not . p) xs)++partition               :: (a -> Bool) -> [a] -> ([a],[a])+{-# INLINE partition #-}+partition p xs = foldr (select p) ([],[]) xs++select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])+select p x ~(ts,fs) | p x       = (x:ts,fs)+                    | otherwise = (ts, x:fs)++-- | The 'mapAccumL' function behaves like a combination of 'map' and+-- 'foldl'; it applies a function to each element of a list, passing+-- an accumulating parameter from left to right, and returning a final+-- value of this accumulator together with the new list.+mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list+                                    -- and accumulator, returning new+                                    -- accumulator and elt of result list+          -> acc            -- Initial accumulator +          -> [x]            -- Input list+          -> (acc, [y])     -- Final accumulator and result list+mapAccumL _ s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++-- | The 'mapAccumR' function behaves like a combination of 'map' and+-- 'foldr'; it applies a function to each element of a list, passing+-- an accumulating parameter from right to left, and returning a final+-- value of this accumulator together with the new list.+mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list+                                        -- and accumulator, returning new+                                        -- accumulator and elt of result list+            -> acc              -- Initial accumulator+            -> [x]              -- Input list+            -> (acc, [y])               -- Final accumulator and result list+mapAccumR _ s []        =  (s, [])+mapAccumR f s (x:xs)    =  (s'', y:ys)+                           where (s'',y ) = f s' x+                                 (s', ys) = mapAccumR f s xs++-- | The 'insert' function takes an element and a list and inserts the+-- element into the list at the last position where it is still less+-- than or equal to the next element.  In particular, if the list+-- is sorted before the call, the result will also be sorted.+-- It is a special case of 'insertBy', which allows the programmer to+-- supply their own comparison function.+insert :: Ord a => a -> [a] -> [a]+insert e ls = insertBy (compare) e ls++-- | The non-overloaded version of 'insert'.+insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertBy _   x [] = [x]+insertBy cmp x ys@(y:ys')+ = case cmp x y of+     GT -> y : insertBy cmp x ys'+     _  -> x : ys++#ifdef __GLASGOW_HASKELL__++-- | 'maximum' returns the maximum value from a list,+-- which must be non-empty, finite, and of an ordered type.+-- It is a special case of 'Data.List.maximumBy', which allows the+-- programmer to supply their own comparison function.+maximum                 :: (Ord a) => [a] -> a+maximum []              =  errorEmptyList "maximum"+maximum xs              =  foldl1 max xs++{-# RULES+  "maximumInt"     maximum = (strictMaximum :: [Int]     -> Int);+  "maximumInteger" maximum = (strictMaximum :: [Integer] -> Integer)+ #-}++-- We can't make the overloaded version of maximum strict without+-- changing its semantics (max might not be strict), but we can for+-- the version specialised to 'Int'.+strictMaximum           :: (Ord a) => [a] -> a+strictMaximum []        =  errorEmptyList "maximum"+strictMaximum xs        =  foldl1' max xs++-- | 'minimum' returns the minimum value from a list,+-- which must be non-empty, finite, and of an ordered type.+-- It is a special case of 'Data.List.minimumBy', which allows the+-- programmer to supply their own comparison function.+minimum                 :: (Ord a) => [a] -> a+minimum []              =  errorEmptyList "minimum"+minimum xs              =  foldl1 min xs++{-# RULES+  "minimumInt"     minimum = (strictMinimum :: [Int]     -> Int);+  "minimumInteger" minimum = (strictMinimum :: [Integer] -> Integer)+ #-}++strictMinimum           :: (Ord a) => [a] -> a+strictMinimum []        =  errorEmptyList "minimum"+strictMinimum xs        =  foldl1' min xs++#endif /* __GLASGOW_HASKELL__ */++-- | The 'maximumBy' function takes a comparison function and a list+-- and returns the greatest element of the list by the comparison function.+-- The list must be finite and non-empty.+maximumBy               :: (a -> a -> Ordering) -> [a] -> a+maximumBy _ []          =  error "List.maximumBy: empty list"+maximumBy cmp xs        =  foldl1 maxBy xs+                        where+                           maxBy x y = case cmp x y of+                                       GT -> x+                                       _  -> y++-- | The 'minimumBy' function takes a comparison function and a list+-- and returns the least element of the list by the comparison function.+-- The list must be finite and non-empty.+minimumBy               :: (a -> a -> Ordering) -> [a] -> a+minimumBy _ []          =  error "List.minimumBy: empty list"+minimumBy cmp xs        =  foldl1 minBy xs+                        where+                           minBy x y = case cmp x y of+                                       GT -> y+                                       _  -> x++-- | The 'genericLength' function is an overloaded version of 'length'.  In+-- particular, instead of returning an 'Int', it returns any type which is+-- an instance of 'Num'.  It is, however, less efficient than 'length'.+genericLength           :: (Num i) => [b] -> i+genericLength []        =  0+genericLength (_:l)     =  1 + genericLength l++-- | The 'genericTake' function is an overloaded version of 'take', which+-- accepts any 'Integral' value as the number of elements to take.+genericTake             :: (Integral i) => i -> [a] -> [a]+genericTake n _ | n <= 0 = []+genericTake _ []        =  []+genericTake n (x:xs)    =  x : genericTake (n-1) xs++-- | The 'genericDrop' function is an overloaded version of 'drop', which+-- accepts any 'Integral' value as the number of elements to drop.+genericDrop             :: (Integral i) => i -> [a] -> [a]+genericDrop n xs | n <= 0 = xs+genericDrop _ []        =  []+genericDrop n (_:xs)    =  genericDrop (n-1) xs+++-- | The 'genericSplitAt' function is an overloaded version of 'splitAt', which+-- accepts any 'Integral' value as the position at which to split.+genericSplitAt          :: (Integral i) => i -> [b] -> ([b],[b])+genericSplitAt n xs | n <= 0 =  ([],xs)+genericSplitAt _ []     =  ([],[])+genericSplitAt n (x:xs) =  (x:xs',xs'') where+    (xs',xs'') = genericSplitAt (n-1) xs++-- | The 'genericIndex' function is an overloaded version of '!!', which+-- accepts any 'Integral' value as the index.+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."++-- | The 'genericReplicate' function is an overloaded version of 'replicate',+-- which accepts any 'Integral' value as the number of repetitions to make.+genericReplicate        :: (Integral i) => i -> a -> [a]+genericReplicate n x    =  genericTake n (repeat x)++-- | The 'zip4' function takes four lists and returns a list of+-- quadruples, analogous to 'zip'.+zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+zip4                    =  zipWith4 (,,,)++-- | The 'zip5' function takes five lists and returns a list of+-- five-tuples, analogous to 'zip'.+zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+zip5                    =  zipWith5 (,,,,)++-- | The 'zip6' function takes six lists and returns a list of six-tuples,+-- analogous to 'zip'.+zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+zip6                    =  zipWith6 (,,,,,)++-- | The 'zip7' function takes seven lists and returns a list of+-- seven-tuples, analogous to 'zip'.+zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+zip7                    =  zipWith7 (,,,,,,)++-- | The 'zipWith4' function takes a function which combines four+-- elements, as well as four lists and returns a list of their point-wise+-- combination, analogous to 'zipWith'.+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 _ _ _ _ _      =  []++-- | The 'zipWith5' function takes a function which combines five+-- elements, as well as five lists and returns a list of their point-wise+-- combination, analogous to 'zipWith'.+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 _ _ _ _ _ _    = []++-- | The 'zipWith6' function takes a function which combines six+-- elements, as well as six lists and returns a list of their point-wise+-- combination, analogous to 'zipWith'.+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 _ _ _ _ _ _ _  = []++-- | The 'zipWith7' function takes a function which combines seven+-- elements, as well as seven lists and returns a list of their point-wise+-- combination, analogous to 'zipWith'.+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 _ _ _ _ _ _ _ _ = []++-- | The 'unzip4' function takes a list of quadruples and returns four+-- lists, analogous to 'unzip'.+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))+                                 ([],[],[],[])++-- | The 'unzip5' function takes a list of five-tuples and returns five+-- lists, analogous to 'unzip'.+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))+                                 ([],[],[],[],[])++-- | The 'unzip6' function takes a list of six-tuples and returns six+-- lists, analogous to 'unzip'.+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))+                                 ([],[],[],[],[],[])++-- | The 'unzip7' function takes a list of seven-tuples and returns+-- seven lists, analogous to 'unzip'.+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))+                         ([],[],[],[],[],[],[])+++-- | The 'deleteFirstsBy' function takes a predicate and two lists and+-- returns the first list with the first occurrence of each element of+-- the second list removed.+deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++-- | The 'group' function takes a list and returns a list of lists such+-- that the concatenation of the result is equal to the argument.  Moreover,+-- each sublist in the result contains only equal elements.  For example,+--+-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]+--+-- It is a special case of 'groupBy', which allows the programmer to supply+-- their own equality test.+group                   :: Eq a => [a] -> [[a]]+group                   =  groupBy (==)++-- | The 'groupBy' function is the non-overloaded version of 'group'.+groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy _  []           =  []+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                           where (ys,zs) = span (eq x) xs++-- | The 'inits' function returns all initial segments of the argument,+-- shortest first.  For example,+--+-- > inits "abc" == ["","a","ab","abc"]+--+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- | The 'tails' function returns all final segments of the argument,+-- longest first.  For example,+--+-- > tails "abc" == ["abc", "bc", "c",""]+--+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs+++-- | The 'subsequences' function returns the list of all subsequences of the argument.+--+-- > subsequences "abc" == ["","a","b","ab","c","ac","bc","abc"]+subsequences            :: [a] -> [[a]]+subsequences xs         =  [] : nonEmptySubsequences xs++-- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument,+--   except for the empty list.+--+-- > nonEmptySubsequences "abc" == ["a","b","ab","c","ac","bc","abc"]+nonEmptySubsequences         :: [a] -> [[a]]+nonEmptySubsequences []      =  []+nonEmptySubsequences (x:xs)  =  [x] : foldr f [] (nonEmptySubsequences xs)+  where f ys r = ys : (x : ys) : r+++-- | The 'permutations' function returns the list of all permutations of the argument.+--+-- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"]+permutations            :: [a] -> [[a]]+permutations xs0        =  xs0 : perms xs0 []+  where+    perms []     _  = []+    perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)+      where interleave    xs     r = let (_,zs) = interleave' id xs r in zs+            interleave' _ []     r = (ts, r)+            interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r+                                     in  (y:us, f (t:y:us) : zs)+++------------------------------------------------------------------------------+-- Quick Sort algorithm taken from HBC's QSort library.++-- | The 'sort' function implements a stable sorting algorithm.+-- It is a special case of 'sortBy', which allows the programmer to supply+-- their own comparison function.+sort :: (Ord a) => [a] -> [a]++-- | The 'sortBy' function is the non-overloaded version of 'sort'.+sortBy :: (a -> a -> Ordering) -> [a] -> [a]++#ifdef USE_REPORT_PRELUDE+sort = sortBy compare+sortBy cmp = foldr (insertBy cmp) []+#else++sortBy cmp l = mergesort cmp l+sort l = mergesort compare l++{-+Quicksort replaced by mergesort, 14/5/2002.++From: Ian Lynagh <igloo@earth.li>++I am curious as to why the List.sort implementation in GHC is a+quicksort algorithm rather than an algorithm that guarantees n log n+time in the worst case? I have attached a mergesort implementation along+with a few scripts to time it's performance, the results of which are+shown below (* means it didn't finish successfully - in all cases this+was due to a stack overflow).++If I heap profile the random_list case with only 10000 then I see+random_list peaks at using about 2.5M of memory, whereas in the same+program using List.sort it uses only 100k.++Input style     Input length     Sort data     Sort alg    User time+stdin           10000            random_list   sort        2.82+stdin           10000            random_list   mergesort   2.96+stdin           10000            sorted        sort        31.37+stdin           10000            sorted        mergesort   1.90+stdin           10000            revsorted     sort        31.21+stdin           10000            revsorted     mergesort   1.88+stdin           100000           random_list   sort        *+stdin           100000           random_list   mergesort   *+stdin           100000           sorted        sort        *+stdin           100000           sorted        mergesort   *+stdin           100000           revsorted     sort        *+stdin           100000           revsorted     mergesort   *+func            10000            random_list   sort        0.31+func            10000            random_list   mergesort   0.91+func            10000            sorted        sort        19.09+func            10000            sorted        mergesort   0.15+func            10000            revsorted     sort        19.17+func            10000            revsorted     mergesort   0.16+func            100000           random_list   sort        3.85+func            100000           random_list   mergesort   *+func            100000           sorted        sort        5831.47+func            100000           sorted        mergesort   2.23+func            100000           revsorted     sort        5872.34+func            100000           revsorted     mergesort   2.24+-}++mergesort :: (a -> a -> Ordering) -> [a] -> [a]+mergesort cmp = mergesort' cmp . map wrap++mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]+mergesort' _   [] = []+mergesort' _   [xs] = xs+mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)++merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]+merge_pairs _   [] = []+merge_pairs _   [xs] = [xs]+merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss++merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+merge _   [] ys = ys+merge _   xs [] = xs+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]++{-+OLD: qsort version++-- qsort is stable and does not concatenate.+qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+qsort _   []     r = r+qsort _   [x]    r = x:r+qsort cmp (x:xs) r = qpart cmp x xs [] [] r++-- qpart partitions and sorts the sublists+qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]+qpart cmp x [] rlt rge r =+    -- rlt and rge are in reverse order and must be sorted with an+    -- anti-stable sorting+    rqsort cmp rlt (x:rqsort cmp rge r)+qpart cmp x (y:ys) rlt rge r =+    case cmp x y of+        GT -> qpart cmp x ys (y:rlt) rge r+        _  -> qpart cmp x ys rlt (y:rge) r++-- rqsort is as qsort but anti-stable, i.e. reverses equal elements+rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+rqsort _   []     r = r+rqsort _   [x]    r = x:r+rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r++rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]+rqpart cmp x [] rle rgt r =+    qsort cmp rle (x:qsort cmp rgt r)+rqpart cmp x (y:ys) rle rgt r =+    case cmp y x of+        GT -> rqpart cmp x ys rle (y:rgt) r+        _  -> rqpart cmp x ys (y:rle) rgt r+-}++#endif /* USE_REPORT_PRELUDE */++-- | The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr'+-- reduces a list to a summary value, 'unfoldr' builds a list from+-- a seed value.  The function takes the element and returns 'Nothing'+-- if it is done producing the list or returns 'Just' @(a,b)@, in which+-- case, @a@ is a prepended to the list and @b@ is used as the next+-- element in a recursive call.  For example,+--+-- > iterate f == unfoldr (\x -> Just (x, f x))+--+-- In some cases, 'unfoldr' can undo a 'foldr' operation:+--+-- > unfoldr f' (foldr f z xs) == xs+--+-- if the following holds:+--+-- > f' (f x y) = Just (x,y)+-- > f' z       = Nothing+--+-- A simple use of unfoldr:+--+-- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10+-- >  [10,9,8,7,6,5,4,3,2,1]+--+unfoldr      :: (b -> Maybe (a, b)) -> b -> [a]+unfoldr f b  =+  case f b of+   Just (a,new_b) -> a : unfoldr f new_b+   Nothing        -> []++-- -----------------------------------------------------------------------------++-- | A strict version of 'foldl'.+foldl'           :: (a -> b -> a) -> a -> [b] -> a+#ifdef __GLASGOW_HASKELL__+foldl' f z0 xs0 = lgo z0 xs0+    where lgo z []     = z+          lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs+#else+foldl' f a []     = a+foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs+#endif++#ifdef __GLASGOW_HASKELL__+-- | 'foldl1' is a variant of 'foldl' that has no starting value argument,+-- and thus must be applied to non-empty lists.+foldl1                  :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)         =  foldl f x xs+foldl1 _ []             =  errorEmptyList "foldl1"+#endif /* __GLASGOW_HASKELL__ */++-- | A strict version of 'foldl1'+foldl1'                  :: (a -> a -> a) -> [a] -> a+foldl1' f (x:xs)         =  foldl' f x xs+foldl1' _ []             =  errorEmptyList "foldl1'"++#ifdef __GLASGOW_HASKELL__+-- -----------------------------------------------------------------------------+-- List sum and product++{-# SPECIALISE sum     :: [Int] -> Int #-}+{-# SPECIALISE sum     :: [Integer] -> Integer #-}+{-# SPECIALISE product :: [Int] -> Int #-}+{-# SPECIALISE product :: [Integer] -> Integer #-}+-- | The 'sum' function computes the sum of a finite list of numbers.+sum                     :: (Num a) => [a] -> a+-- | The 'product' function computes the product of a finite list of numbers.+product                 :: (Num a) => [a] -> a+#ifdef USE_REPORT_PRELUDE+sum                     =  foldl (+) 0+product                 =  foldl (*) 1+#else+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)+#endif++-- -----------------------------------------------------------------------------+-- Functions on strings++-- | 'lines' breaks a string up into a list of strings at newline+-- characters.  The resulting strings do not contain newlines.+lines                   :: String -> [String]+lines ""                =  []+lines s                 =  let (l, s') = break (== '\n') s+                           in  l : case s' of+                                        []      -> []+                                        (_:s'') -> lines s''++-- | 'unlines' is an inverse operation to 'lines'.+-- It joins lines, after appending a terminating newline to each.+unlines                 :: [String] -> String+#ifdef USE_REPORT_PRELUDE+unlines                 =  concatMap (++ "\n")+#else+-- HBC version (stolen)+-- here's a more efficient version+unlines [] = []+unlines (l:ls) = l ++ '\n' : unlines ls+#endif++-- | 'words' breaks a string up into a list of words, which were delimited+-- by white space.+words                   :: String -> [String]+words s                 =  case dropWhile {-partain:Char.-}isSpace s of+                                "" -> []+                                s' -> w : words s''+                                      where (w, s'') =+                                             break {-partain:Char.-}isSpace s'++-- | 'unwords' is an inverse operation to 'words'.+-- It joins words with separating spaces.+unwords                 :: [String] -> String+#ifdef USE_REPORT_PRELUDE+unwords []              =  ""+unwords ws              =  foldr1 (\w s -> w ++ ' ':s) ws+#else+-- HBC version (stolen)+-- here's a more efficient version+unwords []              =  ""+unwords [w]             = w+unwords (w:ws)          = w ++ ' ' : unwords ws+#endif++#else  /* !__GLASGOW_HASKELL__ */++errorEmptyList :: String -> a+errorEmptyList fun =+  error ("Prelude." ++ fun ++ ": empty list")++#endif /* !__GLASGOW_HASKELL__ */
lib/base/src/Data/Maybe.hs view
@@ -1,44 +1,148 @@-{-# OPTIONS_LHC -N #-}-module Data.Maybe(-    isJust, isNothing,-    fromJust, fromMaybe, listToMaybe, maybeToList,-    catMaybes, mapMaybe,+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Maybe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Maybe type, and associated operations.+--+----------------------------------------------------------------------------- -    -- ...and what the Prelude exports-    Maybe(Nothing, Just),-    maybe-  ) where+module Data.Maybe+   (+     Maybe(Nothing,Just)-- instance of: Eq, Ord, Show, Read,+                        --              Functor, Monad, MonadPlus -import Lhc.Maybe-import Lhc.Order-import Lhc.Basics-import Lhc.IO+   , maybe              -- :: b -> (a -> b) -> Maybe a -> b -isJust                 :: Maybe a -> Bool-isJust (Just a)        =  True-isJust Nothing         =  False+   , isJust             -- :: Maybe a -> Bool+   , isNothing          -- :: Maybe a -> Bool+   , fromJust           -- :: Maybe a -> a+   , fromMaybe          -- :: a -> Maybe a -> a+   , listToMaybe        -- :: [a] -> Maybe a+   , maybeToList        -- :: Maybe a -> [a]+   , catMaybes          -- :: [Maybe a] -> [a]+   , mapMaybe           -- :: (a -> Maybe b) -> [a] -> [b]+   ) where -isNothing        :: Maybe a -> Bool-isNothing        =  not . isJust+#ifdef __GLASGOW_HASKELL__+import GHC.Base+#endif -fromJust               :: Maybe a -> a-fromJust (Just a)      =  a-fromJust Nothing       =  error "Maybe.fromJust: Nothing"+#ifdef __NHC__+import Prelude+import Prelude (Maybe(..), maybe)+import Maybe+    ( isJust+    , isNothing+    , fromJust+    , fromMaybe+    , listToMaybe+    , maybeToList+    , catMaybes+    , mapMaybe+    )+#else -fromMaybe              :: a -> Maybe a -> a-fromMaybe d Nothing    =  d-fromMaybe d (Just a)   =  a+#ifndef __HUGS__+-- ---------------------------------------------------------------------------+-- The Maybe type, and instances +-- | The 'Maybe' type encapsulates an optional value.  A value of type+-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing').  Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic+-- measures such as 'error'.+--+-- The 'Maybe' type is also a monad.  It is a simple kind of error+-- monad, where all errors are represented by 'Nothing'.  A richer+-- error monad can be built using the 'Data.Either.Either' type.++data  Maybe a  =  Nothing | Just a+  deriving (Eq, Ord)++instance  Functor Maybe  where+    fmap _ Nothing       = Nothing+    fmap f (Just a)      = Just (f a)++instance  Monad Maybe  where+    (Just x) >>= k      = k x+    Nothing  >>= _      = Nothing++    (Just _) >>  k      = k+    Nothing  >>  _      = Nothing++    return              = Just+    fail _              = Nothing++-- ---------------------------------------------------------------------------+-- Functions over Maybe++-- | The 'maybe' function takes a default value, a function, and a 'Maybe'+-- value.  If the 'Maybe' value is 'Nothing', the function returns the+-- default value.  Otherwise, it applies the function to the value inside+-- the 'Just' and returns the result.+maybe :: b -> (a -> b) -> Maybe a -> b+maybe n _ Nothing  = n+maybe _ f (Just x) = f x+#endif  /* __HUGS__ */++-- | The 'isJust' function returns 'True' iff its argument is of the+-- form @Just _@.+isJust         :: Maybe a -> Bool+isJust Nothing = False+isJust _       = True++-- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'.+isNothing         :: Maybe a -> Bool+isNothing Nothing = True+isNothing _       = False++-- | The 'fromJust' function extracts the element out of a 'Just' and+-- throws an error if its argument is 'Nothing'.+fromJust          :: Maybe a -> a+fromJust Nothing  = error "Maybe.fromJust: Nothing" -- yuck+fromJust (Just x) = x++-- | The 'fromMaybe' function takes a default value and and 'Maybe'+-- value.  If the 'Maybe' is 'Nothing', it returns the default values;+-- otherwise, it returns the value contained in the 'Maybe'.+fromMaybe     :: a -> Maybe a -> a+fromMaybe d x = case x of {Nothing -> d;Just v  -> v}++-- | The 'maybeToList' function returns an empty list when given+-- 'Nothing' or a singleton list when not given 'Nothing'. maybeToList            :: Maybe a -> [a]-maybeToList Nothing    =  []-maybeToList (Just a)   =  [a]+maybeToList  Nothing   = []+maybeToList  (Just x)  = [x] -listToMaybe            :: [a] -> Maybe a-listToMaybe []         =  Nothing-listToMaybe (a:_)      =  Just a+-- | The 'listToMaybe' function returns 'Nothing' on an empty list+-- or @'Just' a@ where @a@ is the first element of the list.+listToMaybe           :: [a] -> Maybe a+listToMaybe []        =  Nothing+listToMaybe (a:_)     =  Just a +-- | The 'catMaybes' function takes a list of 'Maybe's and returns+-- a list of all the 'Just' values.  catMaybes              :: [Maybe a] -> [a]-catMaybes ms           =  [ m | Just m <- ms ]+catMaybes ls = [x | Just x <- ls] -mapMaybe               :: (a -> Maybe b) -> [a] -> [b]-mapMaybe f             =  catMaybes . map f+-- | The 'mapMaybe' function is a version of 'map' which can throw+-- out elements.  In particular, the functional argument returns+-- something of type @'Maybe' b@.  If this is 'Nothing', no element+-- is added on to the result list.  If it just @'Just' b@, then @b@ is+-- included in the result list.+mapMaybe          :: (a -> Maybe b) -> [a] -> [b]+mapMaybe _ []     = []+mapMaybe f (x:xs) =+ let rs = mapMaybe f xs in+ case f x of+  Nothing -> rs+  Just r  -> r:rs++#endif /* else not __NHC__ */
− lib/base/src/Data/Monoid.hs 
@@ -1,90 +0,0 @@--------------------------------------------------------------------------------- |--- 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 :  non-portable (requires extended type classes)------ Declaration of the Monoid class, and instances for list and functions.------	  Inspired by the paper---	  /Functional Programming with Overloading and---	      Higher-Order Polymorphism/,---	    Mark P Jones (<http://www.cse.ogi.edu/~mpj/>)---		  Advanced School of Functional Programming, 1995.--------------------------------------------------------------------------------module Data.Monoid (- 	Monoid(..)-  ) where--import Prelude---- ------------------------------------------------------------------------------ | 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 (a -> a) where-	mempty  = id-	mappend = (.)--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
− lib/base/src/Data/Ratio.hs 
@@ -1,115 +0,0 @@--- Standard functions on rational numbers--module  Data.Ratio (-    Ratio, Rational, (%), numerator, denominator, approxRational ) where--import Prelude.Text-import Prelude.Float(doubleToRational)-import Lhc.Num-import Lhc.Float--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
+ lib/base/src/Data/Tuple.hs view
@@ -0,0 +1,182 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Tuple+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The tuple data types, and associated functions.+--+-----------------------------------------------------------------------------++module Data.Tuple+  ( fst         -- :: (a,b) -> a+  , snd         -- :: (a,b) -> a+  , curry       -- :: ((a, b) -> c) -> a -> b -> c+  , uncurry     -- :: (a -> b -> c) -> ((a, b) -> c)+#ifdef __NHC__+  , (,)(..)+  , (,,)(..)+  , (,,,)(..)+  , (,,,,)(..)+  , (,,,,,)(..)+  , (,,,,,,)(..)+  , (,,,,,,,)(..)+  , (,,,,,,,,)(..)+  , (,,,,,,,,,)(..)+  , (,,,,,,,,,,)(..)+  , (,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,,)(..)+#endif+  )+    where++#ifdef __GLASGOW_HASKELL__+import GHC.Bool+import GHC.Classes+import GHC.Ordering+-- XXX The standalone deriving clauses fail with+--     The data constructors of `(,)' are not all in scope+--       so you cannot derive an instance for it+--     In the stand-alone deriving instance for `Eq (a, b)'+-- if we don't import GHC.Tuple+import GHC.Tuple+#endif  /* __GLASGOW_HASKELL__ */++#ifdef __NHC__+import Prelude+import Prelude+  ( (,)(..)+  , (,,)(..)+  , (,,,)(..)+  , (,,,,)(..)+  , (,,,,,)(..)+  , (,,,,,,)(..)+  , (,,,,,,,)(..)+  , (,,,,,,,,)(..)+  , (,,,,,,,,,)(..)+  , (,,,,,,,,,,)(..)+  , (,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,,)(..)+  -- nhc98's prelude only supplies tuple instances up to size 15+  , fst, snd+  , curry, uncurry+  )+#endif++default ()              -- Double isn't available yet++#ifdef __GLASGOW_HASKELL__+-- XXX Why aren't these derived?+instance Eq () where+    () == () = True+    () /= () = False++instance Ord () where+    () <= () = True+    () <  () = False+    () >= () = True+    () >  () = False+    max () () = ()+    min () () = ()+    compare () () = EQ++#ifndef __HADDOCK__+deriving instance (Eq  a, Eq  b) => Eq  (a, b)+deriving instance (Ord a, Ord b) => Ord (a, b)+deriving instance (Eq  a, Eq  b, Eq  c) => Eq  (a, b, c)+deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c)+deriving instance (Eq  a, Eq  b, Eq  c, Eq  d) => Eq  (a, b, c, d)+deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d)+deriving instance (Eq  a, Eq  b, Eq  c, Eq  d, Eq  e) => Eq  (a, b, c, d, e)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)+               => Eq (a, b, c, d, e, f)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f)+               => Ord (a, b, c, d, e, f)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g)+               => Eq (a, b, c, d, e, f, g)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g)+               => Ord (a, b, c, d, e, f, g)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h)+               => Eq (a, b, c, d, e, f, g, h)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h)+               => Ord (a, b, c, d, e, f, g, h)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i)+               => Eq (a, b, c, d, e, f, g, h, i)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i)+               => Ord (a, b, c, d, e, f, g, h, i)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j)+               => Eq (a, b, c, d, e, f, g, h, i, j)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j)+               => Ord (a, b, c, d, e, f, g, h, i, j)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k)+               => Eq (a, b, c, d, e, f, g, h, i, j, k)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k)+               => Ord (a, b, c, d, e, f, g, h, i, j, k)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+#endif  /* !__HADDOCK__ */+#endif  /* __GLASGOW_HASKELL__ */++-- ---------------------------------------------------------------------------+-- Standard functions over tuples++#if !defined(__HUGS__) && !defined(__NHC__)+-- | Extract the first component of a pair.+fst                     :: (a,b) -> a+fst (x,_)               =  x++-- | Extract the second component of a pair.+snd                     :: (a,b) -> b+snd (_,y)               =  y++-- | 'curry' converts an uncurried function to a curried function.+curry                   :: ((a, b) -> c) -> a -> b -> c+curry f x y             =  f (x, y)++-- | 'uncurry' converts a curried function to a function on pairs.+uncurry                 :: (a -> b -> c) -> ((a, b) -> c)+uncurry f p             =  f (fst p) (snd p)+#endif  /* neither __HUGS__ nor __NHC__ */
lib/base/src/Data/Typeable.hs view
@@ -1,63 +1,647 @@-{-# OPTIONS_LHC -fffi #-}-module Data.Typeable(TypeRep,typeOf) where+{-# OPTIONS_GHC -XNoImplicitPrelude -XOverlappingInstances -funbox-strict-fields #-} +-- The -XOverlappingInstances flag allows the user to over-ride+-- the instances for Typeable given here.  In particular, we provide an instance+--      instance ... => Typeable (s a) +-- But a user might want to say+--      instance ... => Typeable (MyType a b) -data TypeRep+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Typeable+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The 'Typeable' class reifies types to some extent by associating type+-- representations to types. These type representations can be compared,+-- and one can in turn define a type-safe cast operation. To this end,+-- an unsafe cast is guarded by a test for type (representation)+-- equivalence. The module "Data.Dynamic" uses Typeable for an+-- implementation of dynamics. The module "Data.Generics" uses Typeable+-- and type-safe cast (but not dynamics) to support the \"Scrap your+-- boilerplate\" style of generic programming.+--+----------------------------------------------------------------------------- +module Data.Typeable+  (++        -- * The Typeable class+        Typeable( typeOf ),     -- :: a -> TypeRep++        -- * Type-safe cast+        cast,                   -- :: (Typeable a, Typeable b) => a -> Maybe b+        gcast,                  -- a generalisation of cast++        -- * Type representations+        TypeRep,        -- abstract, instance of: Eq, Show, Typeable+        TyCon,          -- abstract, instance of: Eq, Show, Typeable+        showsTypeRep,++        -- * Construction of type representations+        mkTyCon,        -- :: String  -> TyCon+        mkTyConApp,     -- :: TyCon   -> [TypeRep] -> TypeRep+        mkAppTy,        -- :: TypeRep -> TypeRep   -> TypeRep+        mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep++        -- * Observation of type representations+        splitTyConApp,  -- :: TypeRep -> (TyCon, [TypeRep])+        funResultTy,    -- :: TypeRep -> TypeRep   -> Maybe TypeRep+        typeRepTyCon,   -- :: TypeRep -> TyCon+        typeRepArgs,    -- :: TypeRep -> [TypeRep]+        tyConString,    -- :: TyCon   -> String+        typeRepKey,     -- :: TypeRep -> IO Int++        -- * The other Typeable classes+        -- | /Note:/ The general instances are provided for GHC only.+        Typeable1( typeOf1 ),   -- :: t a -> TypeRep+        Typeable2( typeOf2 ),   -- :: t a b -> TypeRep+        Typeable3( typeOf3 ),   -- :: t a b c -> TypeRep+        Typeable4( typeOf4 ),   -- :: t a b c d -> TypeRep+        Typeable5( typeOf5 ),   -- :: t a b c d e -> TypeRep+        Typeable6( typeOf6 ),   -- :: t a b c d e f -> TypeRep+        Typeable7( typeOf7 ),   -- :: t a b c d e f g -> TypeRep+        gcast1,                 -- :: ... => c (t a) -> Maybe (c (t' a))+        gcast2,                 -- :: ... => c (t a b) -> Maybe (c (t' a b))++        -- * Default instances+        -- | /Note:/ These are not needed by GHC, for which these instances+        -- are generated by general instance declarations.+        typeOfDefault,  -- :: (Typeable1 t, Typeable a) => t a -> TypeRep+        typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep+        typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep+        typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep+        typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep+        typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep+        typeOf6Default  -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep++  ) where++import qualified Data.HashTable as HT+import Data.Maybe+import Data.Int+import Data.Word+import Data.List( foldl, intersperse )+import Unsafe.Coerce++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Show         (Show(..), ShowS,+                         shows, showString, showChar, showParen)+import GHC.Err          (undefined)+import GHC.Num          (Integer, fromInteger, (+))+import GHC.Real         ( rem, Ratio )+import GHC.IOBase       (IORef,newIORef,unsafePerformIO)++-- These imports are so we can define Typeable instances+-- It'd be better to give Typeable instances in the modules themselves+-- but they all have to be compiled before Typeable+import GHC.IOBase       ( IOArray, IO, MVar, Handle, block )+import GHC.ST           ( ST )+import GHC.STRef        ( STRef )+import GHC.Ptr          ( Ptr, FunPtr )+import GHC.Stable       ( StablePtr, newStablePtr, freeStablePtr,+                          deRefStablePtr, castStablePtrToPtr,+                          castPtrToStablePtr )+import GHC.Arr          ( Array, STArray )++#endif++#ifdef __HUGS__+import Hugs.Prelude     ( Key(..), TypeRep(..), TyCon(..), Ratio,+                          Handle, Ptr, FunPtr, ForeignPtr, StablePtr )+import Hugs.IORef       ( IORef, newIORef, readIORef, writeIORef )+import Hugs.IOExts      ( unsafePerformIO )+        -- For the Typeable instance+import Hugs.Array       ( Array )+import Hugs.IOArray+import Hugs.ConcBase    ( MVar )+#endif++#ifdef __NHC__+import NHC.IOExtras (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)+import IO (Handle)+import Ratio (Ratio)+        -- For the Typeable instance+import NHC.FFI  ( Ptr,FunPtr,StablePtr,ForeignPtr )+import Array    ( Array )+#endif++#include "Typeable.h"++#ifndef __HUGS__++-------------------------------------------------------------+--+--              Type representations+--+-------------------------------------------------------------++-- | A concrete representation of a (monomorphic) type.  'TypeRep'+-- supports reasonably efficient equality.+data TypeRep = TypeRep !Key TyCon [TypeRep] ++-- Compare keys for equality instance Eq TypeRep where-    (==) = primTypeRepEq+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2 -foreign import primitive typeOf :: a -> TypeRep-foreign import primitive typeOf1 :: t a -> TypeRep-foreign import primitive typeOf2 :: t a b -> TypeRep-foreign import primitive typeOf3 :: t a b c -> TypeRep-foreign import primitive typeOf4 :: t a b c d -> TypeRep-foreign import primitive typeOf5 :: t a b c d e -> TypeRep-foreign import primitive typeOf6 :: t a b c d e f -> TypeRep-foreign import primitive typeOf7 :: t a b c d e f g -> TypeRep-foreign import primitive typeRepEq :: TypeRep -> TypeRep -> Bool+-- | An abstract representation of a type constructor.  'TyCon' objects can+-- be built using 'mkTyCon'.+data TyCon = TyCon !Key String +instance Eq TyCon where+  (TyCon t1 _) == (TyCon t2 _) = t1 == t2+#endif +-- | Returns a unique integer associated with a 'TypeRep'.  This can+-- be used for making a mapping with TypeReps+-- as the keys, for example.  It is guaranteed that @t1 == t2@ if and only if+-- @typeRepKey t1 == typeRepKey t2@.+--+-- It is in the 'IO' monad because the actual value of the key may+-- vary from run to run of the program.  You should only rely on+-- the equality property, not any actual key value.  The relative ordering+-- of keys has no meaning either.+--+typeRepKey :: TypeRep -> IO Int+typeRepKey (TypeRep (Key i) _ _) = return i++        -- +        -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")+        --                                 [fTy,fTy,fTy])+        -- +        -- returns "(Foo,Foo,Foo)"+        --+        -- The TypeRep Show instance promises to print tuple types+        -- correctly. Tuple type constructors are specified by a +        -- sequence of commas, e.g., (mkTyCon ",,,,") returns+        -- the 5-tuple tycon.++----------------- Construction --------------------++-- | Applies a type constructor to a sequence of types+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep+mkTyConApp tc@(TyCon tc_k _) args +  = TypeRep (appKeys tc_k arg_ks) tc args+  where+    arg_ks = [k | TypeRep k _ _ <- args]++-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types.+mkFunTy  :: TypeRep -> TypeRep -> TypeRep+mkFunTy f a = mkTyConApp funTc [f,a]++-- | Splits a type constructor application+splitTyConApp :: TypeRep -> (TyCon,[TypeRep])+splitTyConApp (TypeRep _ tc trs) = (tc,trs)++-- | Applies a type to a function type.  Returns: @'Just' u@ if the+-- first argument represents a function of type @t -> u@ and the+-- second argument represents a function of type @t@.  Otherwise,+-- returns 'Nothing'.+funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep+funResultTy trFun trArg+  = case splitTyConApp trFun of+      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2+      _ -> Nothing++-- | Adds a TypeRep argument to a TypeRep.+mkAppTy :: TypeRep -> TypeRep -> TypeRep+mkAppTy (TypeRep tr_k tc trs) arg_tr+  = let (TypeRep arg_k _ _) = arg_tr+     in  TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])++-- If we enforce the restriction that there is only one+-- @TyCon@ for a type & it is shared among all its uses,+-- we can map them onto Ints very simply. The benefit is,+-- of course, that @TyCon@s can then be compared efficiently.++-- Provided the implementor of other @Typeable@ instances+-- takes care of making all the @TyCon@s CAFs (toplevel constants),+-- this will work. ++-- If this constraint does turn out to be a sore thumb, changing+-- the Eq instance for TyCons is trivial.++-- | Builds a 'TyCon' object representing a type constructor.  An+-- implementation of "Data.Typeable" should ensure that the following holds:+--+-- >  mkTyCon "a" == mkTyCon "a"+--++mkTyCon :: String       -- ^ the name of the type constructor (should be unique+                        -- in the program, so it might be wise to use the+                        -- fully qualified name).+        -> TyCon        -- ^ A unique 'TyCon' object+mkTyCon str = TyCon (mkTyConKey str) str++----------------- Observation ---------------------++-- | Observe the type constructor of a type representation+typeRepTyCon :: TypeRep -> TyCon+typeRepTyCon (TypeRep _ tc _) = tc++-- | Observe the argument types of a type representation+typeRepArgs :: TypeRep -> [TypeRep]+typeRepArgs (TypeRep _ _ args) = args++-- | Observe string encoding of a type representation+tyConString :: TyCon   -> String+tyConString  (TyCon _ str) = str++----------------- Showing TypeReps --------------------++instance Show TypeRep where+  showsPrec p (TypeRep _ tycon tys) =+    case tys of+      [] -> showsPrec p tycon+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'+      [a,r] | tycon == funTc  -> showParen (p > 8) $+                                 showsPrec 9 a .+                                 showString " -> " .+                                 showsPrec 8 r+      xs | isTupleTyCon tycon -> showTuple xs+         | otherwise         ->+            showParen (p > 9) $+            showsPrec p tycon . +            showChar ' '      . +            showArgs tys++showsTypeRep :: TypeRep -> ShowS+showsTypeRep = shows++instance Show TyCon where+  showsPrec _ (TyCon _ s) = showString s++isTupleTyCon :: TyCon -> Bool+isTupleTyCon (TyCon _ ('(':',':_)) = True+isTupleTyCon _                     = False++-- Some (Show.TypeRep) helpers:++showArgs :: Show a => [a] -> ShowS+showArgs [] = id+showArgs [a] = showsPrec 10 a+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as ++showTuple :: [TypeRep] -> ShowS+showTuple args = showChar '('+               . (foldr (.) id $ intersperse (showChar ',') +                               $ map (showsPrec 10) args)+               . showChar ')'+ ------------------------------------------------------------- -----		Type-safe cast+--      The Typeable class and friends -- ------------------------------------------------------------- +-- | The class 'Typeable' allows a concrete representation of a type to+-- be calculated.+class Typeable a where+  typeOf :: a -> TypeRep+  -- ^ Takes a value of type @a@ and returns a concrete representation+  -- of that type.  The /value/ of the argument should be ignored by+  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as+  -- the argument.++-- | Variant for unary type constructors+class Typeable1 t where+  typeOf1 :: t a -> TypeRep++-- | For defining a 'Typeable' instance from any 'Typeable1' instance.+typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep+typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a -> a+   argType =  undefined++-- | Variant for binary type constructors+class Typeable2 t where+  typeOf2 :: t a b -> TypeRep++-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.+typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep+typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b -> a+   argType =  undefined++-- | Variant for 3-ary type constructors+class Typeable3 t where+  typeOf3 :: t a b c -> TypeRep++-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.+typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep+typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c -> a+   argType =  undefined++-- | Variant for 4-ary type constructors+class Typeable4 t where+  typeOf4 :: t a b c d -> TypeRep++-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.+typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep+typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d -> a+   argType =  undefined++-- | Variant for 5-ary type constructors+class Typeable5 t where+  typeOf5 :: t a b c d e -> TypeRep++-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.+typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep+typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d e -> a+   argType =  undefined++-- | Variant for 6-ary type constructors+class Typeable6 t where+  typeOf6 :: t a b c d e f -> TypeRep++-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.+typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep+typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d e f -> a+   argType =  undefined++-- | Variant for 7-ary type constructors+class Typeable7 t where+  typeOf7 :: t a b c d e f g -> TypeRep++-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.+typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep+typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d e f g -> a+   argType =  undefined++#ifdef __GLASGOW_HASKELL__+-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,+-- define the instances for partial applications.+-- Programmers using non-GHC implementations must do this manually+-- for each type constructor.+-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)++-- | One Typeable instance for all Typeable1 instances+instance (Typeable1 s, Typeable a)+       => Typeable (s a) where+  typeOf = typeOfDefault++-- | One Typeable1 instance for all Typeable2 instances+instance (Typeable2 s, Typeable a)+       => Typeable1 (s a) where+  typeOf1 = typeOf1Default++-- | One Typeable2 instance for all Typeable3 instances+instance (Typeable3 s, Typeable a)+       => Typeable2 (s a) where+  typeOf2 = typeOf2Default++-- | One Typeable3 instance for all Typeable4 instances+instance (Typeable4 s, Typeable a)+       => Typeable3 (s a) where+  typeOf3 = typeOf3Default++-- | One Typeable4 instance for all Typeable5 instances+instance (Typeable5 s, Typeable a)+       => Typeable4 (s a) where+  typeOf4 = typeOf4Default++-- | One Typeable5 instance for all Typeable6 instances+instance (Typeable6 s, Typeable a)+       => Typeable5 (s a) where+  typeOf5 = typeOf5Default++-- | One Typeable6 instance for all Typeable7 instances+instance (Typeable7 s, Typeable a)+       => Typeable6 (s a) where+  typeOf6 = typeOf6Default++#endif /* __GLASGOW_HASKELL__ */++-------------------------------------------------------------+--+--              Type-safe cast+--+-------------------------------------------------------------+ -- | The type-safe cast operation-cast ::  a -> Maybe b+cast :: (Typeable a, Typeable b) => a -> Maybe b cast x = r        where-	 r = if typeOf x == typeOf (fromJust r)+         r = if typeOf x == typeOf (fromJust r)                then Just $ unsafeCoerce x-	       else Nothing+               else Nothing  -- | A flexible variation parameterised in a type constructor-gcast :: c a -> Maybe (c b)+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 :: c x -> x    getArg = undefined  -- | Cast for * -> *-gcast1 ::  c (t a) -> Maybe (c (t' a))+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 :: c x -> x    getArg = undefined  -- | Cast for * -> * -> *-gcast2 ::  c (t a b) -> Maybe (c (t' a b))+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 :: c x -> x    getArg = undefined++-------------------------------------------------------------+--+--      Instances of the Typeable classes for Prelude types+--+-------------------------------------------------------------++INSTANCE_TYPEABLE0((),unitTc,"()")+INSTANCE_TYPEABLE1([],listTc,"[]")+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")+INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")+INSTANCE_TYPEABLE2((->),funTc,"->")+INSTANCE_TYPEABLE1(IO,ioTc,"IO")++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+-- Types defined in GHC.IOBase+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )+#endif++INSTANCE_TYPEABLE2(Array,arrayTc,"Array")+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")++#ifdef __GLASGOW_HASKELL__+-- Hugs has these too, but their Typeable<n> instances are defined+-- elsewhere to keep this module within Haskell 98.+-- This is important because every invocation of runhugs or ffihugs+-- uses this module via Data.Dynamic.+INSTANCE_TYPEABLE2(ST,stTc,"ST")+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")+#endif++#ifndef __NHC__+INSTANCE_TYPEABLE2((,),pairTc,"(,)")+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")+INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")+#endif /* __NHC__ */++INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")+#ifndef __GLASGOW_HASKELL__+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")+#endif+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")++-------------------------------------------------------+--+-- Generate Typeable instances for standard datatypes+--+-------------------------------------------------------++INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")+INSTANCE_TYPEABLE0(Char,charTc,"Char")+INSTANCE_TYPEABLE0(Float,floatTc,"Float")+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")+INSTANCE_TYPEABLE0(Int,intTc,"Int")+#ifndef __NHC__+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )+#endif+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")++INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")++INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")++INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")++#ifdef __GLASGOW_HASKELL__+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")+#endif++---------------------------------------------+--+--              Internals +--+---------------------------------------------++#ifndef __HUGS__+newtype Key = Key Int deriving( Eq )+#endif++data KeyPr = KeyPr !Key !Key deriving( Eq )++hashKP :: KeyPr -> Int32+hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime++data Cache = Cache { next_key :: !(IORef Key),  -- Not used by GHC (calls genSym instead)+                     tc_tbl   :: !(HT.HashTable String Key),+                     ap_tbl   :: !(HT.HashTable KeyPr Key) }++{-# NOINLINE cache #-}+#ifdef __GLASGOW_HASKELL__+foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore"+    getOrSetTypeableStore :: Ptr a -> IO (Ptr a)+#endif++cache :: Cache+cache = unsafePerformIO $ do+                empty_tc_tbl <- HT.new (==) HT.hashString+                empty_ap_tbl <- HT.new (==) hashKP+                key_loc      <- newIORef (Key 1) +                let ret = Cache {       next_key = key_loc,+                                        tc_tbl = empty_tc_tbl, +                                        ap_tbl = empty_ap_tbl }+#ifdef __GLASGOW_HASKELL__ && !defined(__LHC__)+                block $ do+                        stable_ref <- newStablePtr ret+                        let ref = castStablePtrToPtr stable_ref+                        ref2 <- getOrSetTypeableStore ref+                        if ref==ref2+                                then deRefStablePtr stable_ref+                                else do+                                        freeStablePtr stable_ref+                                        deRefStablePtr+                                                (castPtrToStablePtr ref2)+#else+                return ret+#endif++newKey :: IORef Key -> IO Key+#ifdef __GLASGOW_HASKELL__+newKey _ = do i <- genSym; return (Key i)+#else+newKey kloc = do { k@(Key i) <- readIORef kloc ;+                   writeIORef kloc (Key (i+1)) ;+                   return k }+#endif++#ifdef __GLASGOW_HASKELL__+foreign import ccall unsafe "genSymZh"+  genSym :: IO Int+#endif++mkTyConKey :: String -> Key+mkTyConKey str +  = unsafePerformIO $ do+        let Cache {next_key = kloc, tc_tbl = tbl} = cache+        mb_k <- HT.lookup tbl str+        case mb_k of+          Just k  -> return k+          Nothing -> do { k <- newKey kloc ;+                          HT.insert tbl str k ;+                          return k }++appKey :: Key -> Key -> Key+appKey k1 k2+  = unsafePerformIO $ do+        let Cache {next_key = kloc, ap_tbl = tbl} = cache+        mb_k <- HT.lookup tbl kpr+        case mb_k of+          Just k  -> return k+          Nothing -> do { k <- newKey kloc ;+                          HT.insert tbl kpr k ;+                          return k }+  where+    kpr = KeyPr k1 k2++appKeys :: Key -> [Key] -> Key+appKeys k ks = foldl appKey k ks
+ lib/base/src/Data/Typeable.hs-boot view
@@ -0,0 +1,21 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module Data.Typeable where++import Data.Maybe+import GHC.Base+import GHC.Show++data TypeRep+data TyCon++mkTyCon      :: String -> TyCon+mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep+showsTypeRep :: TypeRep -> ShowS++cast :: (Typeable a, Typeable b) => a -> Maybe b++class Typeable a where+  typeOf :: a -> TypeRep+
− lib/base/src/Data/Unicode.hs 
@@ -1,63 +0,0 @@-{-# OPTIONS_LHC -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/base/src/Data/Word.hs view
@@ -1,5 +1,68 @@-{-# OPTIONS -N #-}-module Data.Word(Word,Word8,Word16,Word32,Word64,WordMax,WordPtr) where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Unsigned integer types.+--+----------------------------------------------------------------------------- -import Lhc.Prim+module Data.Word+  (+        -- * Unsigned integral types +        Word,+        Word8, Word16, Word32, Word64,++        -- * Notes++        -- $notes+        ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Word+#endif++#ifdef __HUGS__+import Hugs.Word+#endif++#ifdef __NHC__+import NHC.FFI (Word8, Word16, Word32, Word64)+import NHC.SizedTypes (Word8, Word16, Word32, Word64)   -- instances of Bits+type Word = Word32+#endif++{- $notes++* All arithmetic is performed modulo 2^n, where n is the number of+  bits in the type.  One non-obvious consequence of this is that 'Prelude.negate'+  should /not/ raise an error on negative arguments.++* For coercing between any two integer types, use+  'Prelude.fromIntegral', which is specialized for all the+  common cases so should be fast enough.  Coercing word types to and+  from integer types preserves representation, not sign.++* It would be very natural to add a type @Natural@ providing an unbounded +  size unsigned integer, just as 'Prelude.Integer' provides unbounded+  size signed integers.  We do not do that yet since there is no demand+  for it.++* The rules that hold for 'Prelude.Enum' instances over a bounded type+  such as 'Prelude.Int' (see the section of the Haskell report dealing+  with arithmetic sequences) also hold for the 'Prelude.Enum' instances+  over the various 'Word' types defined here.++* Right and left shifts by amounts greater than or equal to the width+  of the type result in a zero result.  This is contrary to the+  behaviour in C, which is undefined; a common interpretation is to+  truncate the shift count to the width of the type, for example @1 \<\<+  32 == 1@ in some C implementations. +-}
− lib/base/src/Debug/Trace.hs 
@@ -1,23 +0,0 @@--- | Tracing library-module Debug.Trace (-  putTraceMsg -- :: String -> IO ()-, trace       -- :: String -> a -> a-, traceShow   -- :: Show a => a -> b -> b-) where-import System.IO (hPutStrLn,stderr)-import System.IO.Unsafe (unsafePerformIO)---- | Outputs a trace message to stderr; currently defined as--- @putTraceMsg = hPutStrLn stderr@-putTraceMsg :: String -> IO ()-putTraceMsg = hPutStrLn stderr---- | Tracing call-trace :: String -> a -> a-trace s e = unsafePerformIO $ do putTraceMsg s-                                 return e---- | Like 'trace', but uses show; defined as--- @traceShow = trace . show@-traceShow :: Show a => a -> b -> b-traceShow = trace . show
lib/base/src/Foreign.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_LHC -N #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module      :  Foreign@@ -18,7 +18,7 @@         ( module Data.Bits         , module Data.Int         , module Data.Word-	, module Foreign.Ptr+        , module Foreign.Ptr         , module Foreign.ForeignPtr         , module Foreign.StablePtr         , module Foreign.Storable
lib/base/src/Foreign/C.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module      :  Foreign.C
− lib/base/src/Foreign/C/Error.hs 
@@ -1,539 +0,0 @@-{-# OPTIONS_LHC -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.Storable-import Foreign.Ptr-import Foreign.C.Types-import Foreign.C.String--import System.IO.Unsafe		( unsafePerformIO )------ "errno" type--- ---------------- | 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--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/base/src/Foreign/C/Error.hsc view
@@ -0,0 +1,613 @@+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}+-----------------------------------------------------------------------------+-- |+-- 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, eAFNOSUPPORT, eAGAIN,+  eALREADY, eBADF, eBADMSG, eBUSY, eCHILD, eCONNABORTED,+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDOM, eDQUOT,+  eEXIST, eFAULT, eFBIG, 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, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE,+  ePROTO, ePROTONOSUPPORT, ePROTOTYPE,+  eRANGE, eREMOTE, eROFS, eSHUTDOWN,+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSTALE, eTIME, eTIMEDOUT,+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV,+  {- unused; may go back in somehow?+  eADV, eCOMM, eNONET, eREMCHG, eSRMNT,+  -}+  -- ** '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,++  throwErrnoPath,+  throwErrnoPathIf,+  throwErrnoPathIf_,+  throwErrnoPathIfNull,+  throwErrnoPathIfMinus1,+  throwErrnoPathIfMinus1_,+) where+++-- this is were we get the CONST_XXX definitions from that configure+-- calculated for us+--+#ifndef __NHC__+#endif++#define __LHC__ 1+#define __GLASGOW_HASKELL__ 1++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Error    ( void )+import Data.Maybe++#if __GLASGOW_HASKELL__+import GHC.IOBase+import GHC.Num+import GHC.Base+#elif __HUGS__+import Hugs.Prelude             ( Handle, IOError, ioError )+import System.IO.Unsafe         ( unsafePerformIO )+#else+import System.IO                ( Handle )+import System.IO.Error          ( IOError, ioError )+import System.IO.Unsafe         ( unsafePerformIO )+import Foreign.Storable         ( Storable(poke,peek) )+#endif++#ifdef __HUGS__+{-# CFILES cbits/PrelIOUtils.c #-}+#endif++-- "errno" type+-- ------------++-- | 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++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, eAFNOSUPPORT, eAGAIN,+  eALREADY, eBADF, eBADMSG, eBUSY, eCHILD, eCONNABORTED,+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDOM, eDQUOT,+  eEXIST, eFAULT, eFBIG, 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, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE,+  ePROTO, ePROTONOSUPPORT, ePROTOTYPE,+  eRANGE, eREMOTE, eROFS, eSHUTDOWN,+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSTALE, eTIME, eTIMEDOUT,+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV                    :: Errno+{- eADV, eCOMM, eNONET, eREMCHG, eSRMNT :: Errno -}+--+-- the cCONST_XXX identifiers are cpp symbols whose value is computed by+-- configure+--+eOK             = Errno 0+#ifdef __NHC__+#include "Errno.hs"+#else+#include "errno.h"+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.+#ifdef __NHC__+getErrno = do e <- peek _errno; return (Errno e)+foreign import ccall unsafe "errno.h &errno" _errno :: Ptr CInt+#else+getErrno = do e <- get_errno; return (Errno e)+foreign import ccall unsafe "HsBase.h __hscore_get_errno" get_errno :: IO CInt+#endif++-- | Reset the current thread\'s @errno@ value to 'eOK'.+--+resetErrno :: IO ()++-- Again, setting errno has to be done via a C function.+#ifdef __NHC__+resetErrno = poke _errno 0+#else+resetErrno = set_errno 0+foreign import ccall unsafe "HsBase.h __hscore_set_errno" set_errno :: CInt -> IO ()+#endif++-- 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  = void $ throwErrnoIf pred loc f++-- | 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  = void $ throwErrnoIfRetry pred loc f++-- | as 'throwErrnoIfRetryMayBlock', but discards the result.+--+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()+throwErrnoIfRetryMayBlock_ pred loc f on_block+  = void $ throwErrnoIfRetryMayBlock pred loc f on_block++-- | 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)++-- | as 'throwErrno', but exceptions include the given path when appropriate.+--+throwErrnoPath :: String -> FilePath -> IO a+throwErrnoPath loc path =+  do+    errno <- getErrno+    ioError (errnoToIOError loc errno Nothing (Just path))++-- | as 'throwErrnoIf', but exceptions include the given path when+--   appropriate.+--+throwErrnoPathIf :: (a -> Bool) -> String -> FilePath -> IO a -> IO a+throwErrnoPathIf pred loc path f =+  do+    res <- f+    if pred res then throwErrnoPath loc path else return res++-- | as 'throwErrnoIf_', but exceptions include the given path when+--   appropriate.+--+throwErrnoPathIf_ :: (a -> Bool) -> String -> FilePath -> IO a -> IO ()+throwErrnoPathIf_ pred loc path f  = void $ throwErrnoPathIf pred loc path f++-- | as 'throwErrnoIfNull', but exceptions include the given path when+--   appropriate.+--+throwErrnoPathIfNull :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a)+throwErrnoPathIfNull  = throwErrnoPathIf (== nullPtr)++-- | as 'throwErrnoIfMinus1', but exceptions include the given path when+--   appropriate.+--+throwErrnoPathIfMinus1 :: Num a => String -> FilePath -> IO a -> IO a+throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)++-- | as 'throwErrnoIfMinus1_', but exceptions include the given path when+--   appropriate.+--+throwErrnoPathIfMinus1_ :: Num a => String -> FilePath -> IO a -> IO ()+throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)++-- 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 Handle -- ^ 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           = InvalidArgument+        | 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+    return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))+#endif++foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
− lib/base/src/Foreign/C/OldString.hs 
@@ -1,36 +0,0 @@-module Foreign.C.String where--import Char-import Foreign.C.Types-import Foreign.Marshal.Array-import Foreign.Ptr-import Data.Word--type CString = Ptr CChar-type CStringLen = (Ptr CChar, Int)--nUL :: CChar-nUL = 0--peekCString :: CString -> IO String-peekCString cp = do-    cs <- peekArray0 nUL cp-    return (cCharsToChars cs)---- TODO UTF8--- cast [CChar] to [Char]----cCharsToChars :: [CChar] -> [Char]-cCharsToChars xs  = map castCCharToChar xs---- cast [Char] to [CChar]----charsToCChars :: [Char] -> [CChar]-charsToCChars xs  = map castCharToCChar xs--castCCharToChar :: CChar -> Char-castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))--castCharToCChar :: Char -> CChar-castCharToCChar ch = fromIntegral (ord ch)-
lib/base/src/Foreign/C/String.hs view
@@ -1,10 +1,10 @@-{-# OPTIONS_LHC -N -fffi #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- 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@@ -88,11 +88,6 @@    ) where -import Lhc.Basics-import Lhc.Monad-import Lhc.Order-import Lhc.List-import Lhc.Num import Foreign.Marshal.Array import Foreign.C.Types import Foreign.Ptr@@ -100,6 +95,16 @@  import Data.Word +#ifdef __GLASGOW_HASKELL__+import GHC.List+import GHC.Real+import GHC.Num+import GHC.IOBase+import GHC.Base+#else+import Data.Char ( chr, ord )+#define unsafeChr chr+#endif  ----------------------------------------------------------------------------- -- Strings@@ -163,10 +168,8 @@ 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+-- | Marshal a Haskell string into a C string (ie, character array)+-- in temporary storage, with explicit length information. -- -- * the memory is freed when the subcomputation terminates (either --   normally or via an exception), so the pointer to the temporary@@ -189,54 +192,52 @@  -- | Convert a C byte, representing a Latin-1 character, to the corresponding -- Haskell character.---castCCharToChar :: CChar -> Char---castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))+castCCharToChar :: CChar -> Char+castCCharToChar ch = unsafeChr (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+castCharToCChar :: Char -> CChar+castCharToCChar ch = fromIntegral (ord ch)  -- | 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+#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+  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+        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)+#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+         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. --@@ -247,17 +248,17 @@ --   'Foreign.Marshal.Alloc.finalizerFree'. -- newCAString :: String -> IO CString---  #ifndef __GLASGOW_HASKELL__--- newCAString  = newArray0 nUL . charsToCChars---  #else+#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 [] 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+#endif  -- | Marshal a Haskell string into a C string (ie, character array) with -- explicit length information.@@ -267,20 +268,19 @@ --   'Foreign.Marshal.Alloc.finalizerFree'. -- newCAStringLen     :: String -> IO CStringLen---  #ifndef __GLASGOW_HASKELL__--- newCAStringLen str  = do---   a <- newArray (charsToCChars str)---  return (pairLength str a)---  #else+#ifndef __GLASGOW_HASKELL__+newCAStringLen str  = newArrayLen (charsToCChars str)+#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 [] 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+  return (ptr, len)+  where     len = length str---  #endif+#endif  -- | Marshal a Haskell string into a NUL terminated C string using temporary -- storage.@@ -292,43 +292,41 @@ --   storage must /not/ be used after this. -- withCAString :: String -> (CString -> IO a) -> IO a---  #ifndef __GLASGOW_HASKELL__--- withCAString  = withArray0 nUL . charsToCChars---  #else+#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)+        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+#endif --- | Marshal a Haskell string into a NUL terminated C string using temporary--- storage.------ * the Haskell string may /not/ contain any NUL characters+-- | Marshal a Haskell string into a C string (ie, character array)+-- in temporary storage, with explicit length information. -- -- * 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 =+withCAStringLen         :: String -> (CStringLen -> IO a) -> IO a+withCAStringLen str f    =+#ifndef __GLASGOW_HASKELL__+  withArrayLen (charsToCChars str) $ \ len ptr -> f (ptr, len)+#else   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)+        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+#endif  -- auxiliary definitions -- ----------------------@@ -338,12 +336,13 @@ nUL :: CChar nUL  = 0 --- pair a C string with the length of the given Haskell string----pairLength :: String -> a -> (a, Int)-pairLength  = flip (,) . length+-- allocate an array to hold the list and pair it with the number of elements+newArrayLen        :: Storable a => [a] -> IO (Ptr a, Int)+newArrayLen xs      = do+  a <- newArray xs+  return (a, length xs) ---  #ifndef __GLASGOW_HASKELL__+#ifndef __GLASGOW_HASKELL__ -- cast [CChar] to [Char] -- cCharsToChars :: [CChar] -> [Char]@@ -353,7 +352,7 @@ -- charsToCChars :: [Char] -> [CChar] charsToCChars xs  = map castCharToCChar xs---   #endif+#endif  ----------------------------------------------------------------------------- -- Wide strings@@ -365,7 +364,7 @@ -- terminated by NUL. type CWString    = Ptr CWchar --- | A wide character string with explicit length information in bytes+-- | A wide character string with explicit length information in 'CWchar's -- instead of a terminating NUL (allowing NUL characters in the middle -- of the string). type CWStringLen = (Ptr CWchar, Int)@@ -403,9 +402,7 @@ --   'Foreign.Marshal.Alloc.finalizerFree'. -- newCWStringLen     :: String -> IO CWStringLen-newCWStringLen str  = do-  a <- newArray (charsToCWchars str)-  return (pairLength str a)+newCWStringLen str  = newArrayLen (charsToCWchars str)  -- | Marshal a Haskell string into a NUL terminated C wide string using -- temporary storage.@@ -429,7 +426,8 @@ --   storage must /not/ be used after this. -- withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a-withCWStringLen str act  = withArray (charsToCWchars str) $ act . pairLength str+withCWStringLen str f    =+  withArrayLen (charsToCWchars str) $ \ len ptr -> f (ptr, len)  -- auxiliary definitions -- ----------------------@@ -440,21 +438,39 @@ cWcharsToChars :: [CWchar] -> [Char] charsToCWchars :: [Char] -> [CWchar] +#ifdef mingw32_HOST_OS +-- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding.++-- coding errors generate Chars in the surrogate range+cWcharsToChars = map chr . fromUTF16 . map fromIntegral+ where+  fromUTF16 (c1:c2:wcs)+    | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =+      ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs+  fromUTF16 (c:wcs) = c : fromUTF16 wcs+  fromUTF16 [] = []++charsToCWchars = foldr utf16Char [] . map ord+ where+  utf16Char c wcs+    | c < 0x10000 = fromIntegral c : wcs+    | otherwise   = let c' = c - 0x10000 in+                    fromIntegral (c' `div` 0x400 + 0xd800) :+                    fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs++#else /* !mingw32_HOST_OS */+ 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-+castCWcharToChar :: CWchar -> Char+castCWcharToChar ch = chr (fromIntegral ch ) +castCharToCWchar :: Char -> CWchar+castCharToCWchar ch = fromIntegral (ord ch) +#endif /* !mingw32_HOST_OS */
lib/base/src/Foreign/C/Types.hs view
@@ -1,68 +1,19 @@-{-# OPTIONS --noprelude -fffi -fm4 -funboxed-tuples -funboxed-values #-}-module Foreign.C.Types-  ( CChar(..)-  , CInt(..)-  , CWchar(..)-  , CWint-  , CSize-  ) where---- FIXME: this module really shouldn't import all this stuff. These types should probably--- be defined in another module so that instances can be defined elsewhere.--import Lhc.Types-import Lhc.Num-import Lhc.Order-import Lhc.Prim-import Lhc.Basics-import Foreign.Storable-import Lhc.IO-import Lhc.Int-import Lhc.Addr--data CChar = CChar Bits8_-data CSChar-data CUChar-data CShort = CShort BitsShort_-data CUShort-data CInt = CInt BitsInt_-data CUInt-data CLong-data CULong-data CPtrdiff-data CSize = CSize BitsSize_t_-data CWchar = CWchar Bits32_-data CSigAtomic-data CLLong-data CULLong-data CClock-data CTime-data CFloat-data CDouble-data CLDouble-data CFile-data CJmpBuf-data CFpos-data CWint = CWint Bits32_--m4_include(Lhc/Inst/Num.m4)-m4_include(Lhc/Order.m4)-m4_include(Foreign/Storable.m4)--INST_EQORDER(CInt,BitsInt_)-NUMINST(CInt, BitsInt_)-INST_STORABLE(CInt,BitsInt_,bits<int>)--INST_EQORDER(CSize,BitsSize_t_)-NUMINST(CSize, BitsSize_t_)-INST_STORABLE(CSize,BitsSize_t_,bits<size_t>)--INST_EQORDER(CWchar,Bits32_)-NUMINST(CWchar, Bits32_)-INST_STORABLE(CWchar,Bits32_,bits32)+module Foreign.C.Types where -INST_EQORDER(CChar,Bits8_)-NUMINST(CChar, Bits8_)-INST_STORABLE(CChar,Bits8_,bits8)+import GHC.Base+import GHC.Num+import GHC.Int+import GHC.Word+import GHC.Show+import GHC.Real+import GHC.Enum+import Data.Bits+import {-# SOURCE #-} Foreign.Storable -foreign import primitive "box" boxBool :: Bool__ -> Bool+newtype CInt = CInt Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)+newtype CSize = CSize Word64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)+newtype CChar = CChar Int8 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)+newtype CWchar = CWchar Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)+newtype CClock = CClock Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)+newtype CTime = CTime Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)+newtype CLong = CLong Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits)
lib/base/src/Foreign/ForeignPtr.hs view
@@ -1,55 +1,182 @@--- | Just a dummy skeleton, fixme.+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.ForeignPtr+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'ForeignPtr' type and operations.  This module is part of the+-- Foreign Function Interface (FFI) and will usually be imported via+-- the "Foreign" module.+--+-----------------------------------------------------------------------------+ module Foreign.ForeignPtr-    (ForeignPtr, newForeignPtr_, newForeignPtr,-     addForeignPtrFinalizer, mallocForeignPtr, mallocForeignPtrBytes,-     withForeignPtr, unsafeForeignPtrToPtr, touchForeignPtr, castForeignPtr-    ) where+        ( +        -- * Finalised data pointers+          ForeignPtr+        , FinalizerPtr+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+        , FinalizerEnvPtr+#endif+        -- ** Basic operations+        , newForeignPtr+        , newForeignPtr_+        , addForeignPtrFinalizer+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+        , newForeignPtrEnv+        , addForeignPtrFinalizerEnv+#endif+        , withForeignPtr -import Control.Monad-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array+#ifdef __GLASGOW_HASKELL__+        , finalizeForeignPtr+#endif++        -- ** Low-level operations+        , unsafeForeignPtrToPtr+        , touchForeignPtr+        , castForeignPtr++        -- ** Allocating managed memory+        , mallocForeignPtr+        , mallocForeignPtrBytes+        , mallocForeignPtrArray+        , mallocForeignPtrArray0+        ) +        where+ import Foreign.Ptr-import Foreign.Storable -newtype ForeignPtr a = FP (Ptr a)-type FinalizerPtr  a = Ptr a+#ifdef __NHC__+import NHC.FFI+  ( ForeignPtr+  , FinalizerPtr+  , newForeignPtr+  , newForeignPtr_+  , addForeignPtrFinalizer+  , withForeignPtr+  , unsafeForeignPtrToPtr+  , touchForeignPtr+  , castForeignPtr+  , Storable(sizeOf)+  , malloc, mallocBytes, finalizerFree+  )+#endif -newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)-newForeignPtr_ = return . FP+#ifdef __HUGS__+import Hugs.ForeignPtr+#endif -newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)-newForeignPtr finalizer ptr = do-    fp <- newForeignPtr_ ptr-    addForeignPtrFinalizer finalizer fp-    return fp+#ifndef __NHC__+import Foreign.Storable ( Storable(sizeOf) )+#endif +#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import GHC.Num+import GHC.Err          ( undefined )+import GHC.ForeignPtr+#endif --- newForeignPtrEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a)-addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()-addForeignPtrFinalizer _ _ = return ()+#if !defined(__NHC__) && !defined(__GLASGOW_HASKELL__)+import Foreign.Marshal.Alloc    ( malloc, mallocBytes, finalizerFree ) --- addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()+instance Eq (ForeignPtr a) where +    p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q -mallocForeignPtr :: Storable a => IO (ForeignPtr a)-mallocForeignPtr = liftM FP malloc+instance Ord (ForeignPtr a) where +    compare p q  =  compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q) -mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)-mallocForeignPtrBytes = liftM FP . mallocBytes+instance Show (ForeignPtr a) where+    showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)+#endif -mallocForeignPtrArray  :: Storable a => Int -> IO (ForeignPtr a)-mallocForeignPtrArray = liftM FP . mallocArray --- mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a)--- mallocForeignPtrArray0 = liftM FP . mallocArray0+#ifndef __NHC__+newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)+-- ^Turns a plain memory reference into a foreign pointer, and+-- associates a finaliser with the reference.  The finaliser will be executed+-- after the last reference to the foreign object is dropped.  Note that there+-- is no guarantee on how soon the finaliser is executed after the last+-- reference was dropped; this depends on the details of the Haskell storage+-- manager.  Indeed, there is no guarantee that the finalizer is executed at+-- all; a program may exit with finalizers outstanding.  (This is true+-- of GHC, other implementations may give stronger guarantees).+newForeignPtr finalizer p+  = do fObj <- newForeignPtr_ p+       addForeignPtrFinalizer finalizer fObj+       return fObj  withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b-withForeignPtr (FP p) act = act p+-- ^This is a way to look at the pointer living inside a+-- foreign object.  This function takes a function which is+-- applied to that pointer. The resulting 'IO' action is then+-- executed. The foreign object is kept alive at least during+-- the whole action, even if it is not used directly+-- inside. Note that it is not safe to return the pointer from+-- the action and use it after the action completes. All uses+-- of the pointer should be inside the+-- 'withForeignPtr' bracket.  The reason for+-- this unsafeness is the same as for+-- 'unsafeForeignPtrToPtr' below: the finalizer+-- may run earlier than expected, because the compiler can only+-- track usage of the 'ForeignPtr' object, not+-- a 'Ptr' object made from it.+--+-- This function is normally used for marshalling data to+-- or from the object pointed to by the+-- 'ForeignPtr', using the operations from the+-- 'Storable' class.+withForeignPtr fo io+  = do r <- io (unsafeForeignPtrToPtr fo)+       touchForeignPtr fo+       return r+#endif /* ! __NHC__ */ -unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a-unsafeForeignPtrToPtr (FP x) = x+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+-- | 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 finalizer env p+  = do fObj <- newForeignPtr_ p+       addForeignPtrFinalizerEnv finalizer env fObj+       return fObj+#endif /* __HUGS__ */ -touchForeignPtr :: ForeignPtr a -> IO ()-touchForeignPtr _ = return ()+#ifndef __GLASGOW_HASKELL__+mallocForeignPtr :: Storable a => IO (ForeignPtr a)+mallocForeignPtr = do+  r <- malloc+  newForeignPtr finalizerFree r -castForeignPtr :: ForeignPtr a -> ForeignPtr b-castForeignPtr (FP x) = FP $ castPtr x+mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes n = do+  r <- mallocBytes n+  newForeignPtr finalizerFree r+#endif /* !__GLASGOW_HASKELL__ */++-- | This function is similar to 'Foreign.Marshal.Array.mallocArray',+-- but yields a memory area that has a finalizer attached that releases+-- the memory area.  As with 'mallocForeignPtr', it is not guaranteed that+-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.+mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a)+mallocForeignPtrArray  = doMalloc undefined+  where+    doMalloc            :: Storable b => b -> Int -> IO (ForeignPtr b)+    doMalloc dummy size  = mallocForeignPtrBytes (size * sizeOf dummy)++-- | This function is similar to 'Foreign.Marshal.Array.mallocArray0',+-- but yields a memory area that has a finalizer attached that releases+-- the memory area.  As with 'mallocForeignPtr', it is not guaranteed that+-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.+mallocForeignPtrArray0      :: Storable a => Int -> IO (ForeignPtr a)+mallocForeignPtrArray0 size  = mallocForeignPtrArray (size + 1)
lib/base/src/Foreign/Marshal.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fno-implicit-prelude #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module      :  Foreign.Marshal
lib/base/src/Foreign/Marshal/Alloc.hs view
@@ -1,4 +1,18 @@-{-# OPTIONS_LHC -N -fffi #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Alloc+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support: basic routines for memory allocation+--+-----------------------------------------------------------------------------+ module Foreign.Marshal.Alloc (   -- * Memory allocation   -- ** Local allocation@@ -10,46 +24,42 @@   mallocBytes,  -- ::               Int -> IO (Ptr a)    realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)-  reallocBytes, -- ::		    Ptr a -> Int -> IO (Ptr a)+  reallocBytes, -- ::               Ptr a -> Int -> IO (Ptr a)    free,         -- :: Ptr a -> IO ()   finalizerFree -- :: FinalizerPtr a ) where -import Foreign.Ptr-import Foreign.Storable-import Prelude.IO-import Foreign.C.Types-import Foreign.Marshal.Utils-import Prelude.IOError-import Lhc.Prim-import Lhc.Basics-import Lhc.Monad-import Lhc.Order-import Lhc.IO-import Lhc.Int(unboxInt)-import Lhc.Addr-import Lhc.Num-import qualified Lhc.Options as JO+import Data.Maybe+import Foreign.C.Types          ( CSize )+import Foreign.Storable         ( Storable(sizeOf,alignment) ) +#ifndef __GLASGOW_HASKELL__+import Foreign.Ptr              ( Ptr, nullPtr, FunPtr )+#endif +#ifdef __GLASGOW_HASKELL__+import Foreign.ForeignPtr       ( FinalizerPtr )+import GHC.IOBase+import GHC.Real+import GHC.Ptr+import GHC.Err+import GHC.Base+import GHC.Num+#elif defined(__NHC__)+import NHC.FFI                  ( FinalizerPtr, CInt(..) )+import IO                       ( bracket )+#else+import Control.Exception.Base   ( bracket )+#endif --- 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+#ifdef __HUGS__+import Hugs.Prelude             ( IOException(IOError),+                                  IOErrorType(ResourceExhausted) )+import Hugs.ForeignPtr          ( FinalizerPtr )+#endif -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 -- ------------------ @@ -62,9 +72,19 @@ -- malloc :: Storable a => IO (Ptr a) malloc  = doMalloc undefined-doMalloc       :: Storable b => b -> IO (Ptr b)-doMalloc dummy  = mallocBytes (sizeOf dummy)+  where+    doMalloc       :: Storable b => b -> IO (Ptr b)+    doMalloc dummy  = mallocBytes (sizeOf dummy) +-- |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  = failWhenNULL "malloc" (_malloc (fromIntegral size))  -- |@'alloca' f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory sufficient to@@ -74,28 +94,49 @@ -- 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+alloca  = doAlloca undefined+  where     doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'-    doAlloca dummy fn = allocaBytes (sizeOf dummy) fn--failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)-failWhenNULL name f = do-   addr <- f-   if addr == nullPtr-      then ioError (userError (name++": out of memory"))-      else return addr+    doAlloca dummy  = allocaBytesAligned (sizeOf dummy) (alignment dummy) --- |Allocate a block of memory of the given number of bytes.+-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory of @n@ 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.+-- 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. ---mallocBytes      :: Int -> IO (Ptr a)-mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))+#ifdef __GLASGOW_HASKELL__+allocaBytes :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes (I# size) action = IO $ \ s0 ->+     case newPinnedByteArray# size s0      of { (# s1, mbarr# #) ->+     case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->+     let addr = Ptr (byteArrayContents# barr#) in+     case action addr     of { IO action' ->+     case action' s2      of { (# s3, r #) ->+     case touch# barr# s3 of { s4 ->+     (# s4, r #)+  }}}}} +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b+allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->+     case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) ->+     case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->+     let addr = Ptr (byteArrayContents# barr#) in+     case action addr     of { IO action' ->+     case action' s2      of { (# s3, r #) ->+     case touch# barr# s3 of { s4 ->+     (# s4, r #)+  }}}}}+#else+allocaBytes      :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes size  = bracket (mallocBytes size) free +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b+allocaBytesAligned size align = allocaBytes size -- wrong+#endif+ -- |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@@ -108,11 +149,12 @@ -- 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-                       failWhenNULL "realloc" (_realloc ptr size)+  where+    doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')+    doRealloc dummy ptr  = let+                             size = fromIntegral (sizeOf dummy)+                           in+                           failWhenNULL "realloc" (_realloc ptr size)  -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the given size.  The returned pointer may refer to an entirely@@ -127,11 +169,44 @@ -- 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  =+reallocBytes ptr size  =    failWhenNULL "realloc" (_realloc ptr (fromIntegral size)) -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)+-- |Free a block of memory that was allocated with 'malloc',+-- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new'+-- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or+-- "Foreign.C.String".+--+free :: Ptr a -> IO ()+free  = _free+++-- auxilliary routines+-- -------------------++-- asserts that the pointer returned from the action in the second argument is+-- non-null+--+failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)+failWhenNULL name f = do+   addr <- f+   if addr == nullPtr+#if __GLASGOW_HASKELL__ || __HUGS__+      then ioError (IOError Nothing ResourceExhausted name +                                        "out of memory" Nothing)+#else+      then ioError (userError (name++": out of memory"))+#endif+      else return addr++-- basic C routines needed for memory allocation+--+foreign import ccall unsafe "stdlib.h malloc"  _malloc  ::          CSize -> IO (Ptr a)+foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)+foreign import ccall unsafe "stdlib.h free"    _free    :: Ptr a -> IO ()++-- | 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 :: FinalizerPtr a
lib/base/src/Foreign/Marshal/Array.hs view
@@ -1,4 +1,19 @@-{-# OPTIONS_LHC -N  #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Array+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support: routines allocating, storing, and retrieving Haskell+-- lists that are represented as arrays in the foreign language+--+-----------------------------------------------------------------------------+ module Foreign.Marshal.Array (   -- * Marshalling arrays @@ -47,18 +62,20 @@   advancePtr,     -- :: Storable a => Ptr a -> Int -> Ptr a ) where +import Foreign.Ptr      (Ptr, plusPtr)+import Foreign.Storable (Storable(sizeOf,peekElemOff,pokeElemOff))+import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)+import Foreign.Marshal.Utils (copyBytes, moveBytes) -import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.Storable-import Lhc.Basics-import Lhc.IO-import Lhc.List-import Lhc.Monad-import Lhc.Num-import Lhc.Order-import Prelude.IOError+#ifdef __GLASGOW_HASKELL__+import GHC.IOBase+import GHC.Num+import GHC.List+import GHC.Err+import GHC.Base+#else+import Control.Monad (zipWithM_)+#endif  -- allocation -- ----------@@ -68,8 +85,9 @@ -- 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)+  where+    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.@@ -81,9 +99,10 @@ -- (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+allocaArray  = doAlloca undefined+  where+    doAlloca            :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy size  = allocaBytes (size * sizeOf dummy)  -- |Like 'allocaArray', but add an extra position to hold a special -- termination element.@@ -105,18 +124,21 @@ reallocArray0 ptr size  = reallocArray ptr (size + 1)  +-- marshalling+-- -----------+ -- |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) []+peekArray size ptr | 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]@@ -124,34 +146,32 @@   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-+#ifndef __GLASGOW_HASKELL__+pokeArray ptr vals =  zipWithM_ (pokeElemOff ptr) [0..] vals+#else+pokeArray ptr vals0 = go vals0 0#+  where go [] _          = return ()+        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)+#endif  -- |Write the list elements consecutive into memory and terminate them with the -- given marker element -- pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()+#ifndef __GLASGOW_HASKELL__ pokeArray0 marker ptr vals  = do-  lv <- pokeArray' ptr vals-  pokeElemOff ptr lv marker+  pokeArray ptr vals+  pokeElemOff ptr (length vals) marker+#else+pokeArray0 marker ptr vals0 = go vals0 0#+  where go [] n#         = pokeElemOff ptr (I# n#) marker+        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)+#endif + -- combined allocation and marshalling -- ----------------------------------- @@ -184,8 +204,8 @@ -- 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+withArrayLen vals f  =+  allocaArray len $ \ptr -> do       pokeArray ptr vals       res <- f len ptr       return res@@ -200,8 +220,8 @@ -- |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+withArrayLen0 marker vals f  =+  allocaArray0 len $ \ptr -> do       pokeArray0 marker ptr vals       res <- f len ptr       return res@@ -237,9 +257,9 @@ -- |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+lengthArray0 marker ptr  = loop 0   where-    loop i | i `seq` True = do+    loop i = do         val <- peekElemOff ptr i         if val == marker then return i else loop (i+1)
lib/base/src/Foreign/Marshal/Error.hs view
@@ -1,9 +1,10 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- 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@@ -16,10 +17,10 @@ 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 a   throwIfNeg_,   -- :: (Ord a, Num a)-	         -- =>                (a -> String) -> IO a       -> IO ()+                 -- =>                (a -> String) -> IO a       -> IO ()   throwIfNull,   -- ::                String        -> IO (Ptr a) -> IO (Ptr a)    -- Discard return value@@ -28,9 +29,16 @@ ) where  import Foreign.Ptr-import Prelude.IO-import Prelude.IOError +#ifdef __GLASGOW_HASKELL__+#ifdef __HADDOCK__+import Data.Bool+import System.IO.Error+#endif+import GHC.Base+import GHC.Num+import GHC.IOBase+#endif  -- exported functions -- ------------------@@ -39,12 +47,13 @@ -- '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+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
lib/base/src/Foreign/Marshal/Pool.hs view
@@ -1,10 +1,10 @@-{-# OPTIONS_GHC -fno-implicit-prelude #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-} -------------------------------------------------------------------------------- -- | -- 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@@ -16,13 +16,11 @@ -- 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(+module Foreign.Marshal.Pool (    -- * Pool management-   Pool(),+   Pool,    newPool,             -- :: IO Pool    freePool,            -- :: Pool -> IO ()    withPool,            -- :: (Pool -> IO b) -> IO b@@ -46,11 +44,30 @@    pooledNewArray0      -- :: Storable a => Pool -> a -> [a]     -> IO (Ptr a) ) where -import Control.Exception     ( bracket )-import Foreign.Marshal.Alloc+#ifdef __GLASGOW_HASKELL__+import GHC.Base              ( Int, Monad(..), (.), not )+import GHC.Err               ( undefined )+import GHC.Exception         ( throw )+import GHC.IOBase            ( IO, IORef, newIORef, readIORef, writeIORef,+                               block, unblock, catchAny )+import GHC.List              ( elem, length )+import GHC.Num               ( Num(..) )+#else+import Data.IORef            ( IORef, newIORef, readIORef, writeIORef )+#if defined(__NHC__)+import IO                    ( bracket )+#else+import Control.Exception.Base ( bracket )+#endif+#endif++import Control.Monad         ( liftM )+import Data.List             ( delete )+import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free ) import Foreign.Marshal.Array ( pokeArray, pokeArray0 )-import Foreign.Ptr-import Foreign.Storable+import Foreign.Marshal.Error ( throwIf )+import Foreign.Ptr           ( Ptr, castPtr )+import Foreign.Storable      ( Storable(sizeOf, poke) )  -------------------------------------------------------------------------------- @@ -59,33 +76,37 @@  -- | A memory pool. ---newtype Pool = Pool (Ptr (Ptr ())) -- (IORef [Ptr ()])+newtype Pool = Pool (IORef [Ptr ()])  -- | Allocate a fresh memory pool.  newPool :: IO Pool-newPool = do-    pool <- malloc-    poke pool nullPtr-    return $ Pool pool+newPool = liftM Pool (newIORef [])  -- | 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 ()))+freePool (Pool pool) = readIORef pool >>= freeAll+   where freeAll []     = return ()+         freeAll (p:ps) = free p >> freeAll ps  -- | 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+#ifdef __GLASGOW_HASKELL__+withPool act =   -- ATTENTION: cut-n-paste from Control.Exception below!+   block (do+      pool <- newPool+      val <- catchAny+                (unblock (act pool))+                (\e -> do freePool pool; throw e)+      freePool pool+      return val)+#else withPool = bracket newPool freePool+#endif  -------------------------------------------------------------------------------- @@ -103,10 +124,10 @@  pooledMallocBytes :: Pool -> Int -> IO (Ptr a) pooledMallocBytes (Pool pool) size = do-    ptr <- mallocBytes (size + sizeOf pool)-    v <- peek pool-    poke ptr (v :: Ptr ())-    return ((ptr :: Ptr (Ptr ())) `plusPtr` sizeOf pool)+   ptr <- mallocBytes size+   ptrs <- readIORef pool+   writeIORef pool (ptr:ptrs)+   return (castPtr ptr)  -- | Adjust the storage area for an element in the pool to the given size of -- the required type.@@ -120,13 +141,13 @@ -- | 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)+pooledReallocBytes (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.@@ -186,5 +207,3 @@    ptr <- pooledMallocArray0 pool (length vals)    pokeArray0 marker ptr vals    return ptr--
lib/base/src/Foreign/Marshal/Utils.hs view
@@ -1,10 +1,10 @@-{-# OPTIONS_LHC -N -fffi #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- 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@@ -24,16 +24,16 @@   -- ** Marshalling of Boolean values (non-zero corresponds to 'True')   --   fromBool,      -- :: Num a => Bool -> a-  toBool,	 -- :: Num a => a -> Bool+  toBool,        -- :: Num a => a -> Bool    -- ** Marshalling of Maybe values   --   maybeNew,      -- :: (      a -> IO (Ptr a))-		 -- -> (Maybe 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)+                 -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)   maybePeek,     -- :: (Ptr a -> IO        b )-		 -- -> (Ptr a -> IO (Maybe b))+                 -- -> (Ptr a -> IO (Maybe b))    -- ** Marshalling lists of storable objects   --@@ -43,23 +43,26 @@   -- | (argument order: destination, source)   --   copyBytes,     -- :: Ptr a -> Ptr a -> Int -> IO ()-  moveBytes     -- :: 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 Lhc.Basics-import Lhc.IO-import Lhc.List-import Lhc.Monad-import Lhc.Num-import Lhc.Order-import Lhc.Maybe+import Data.Maybe+import Foreign.Ptr              ( Ptr, nullPtr )+import Foreign.Storable         ( Storable(poke) )+import Foreign.C.Types          ( CSize )+import Foreign.Marshal.Alloc    ( malloc, alloca ) +#ifdef __GLASGOW_HASKELL__+import GHC.IOBase+import GHC.Real                 ( fromIntegral )+import GHC.Num+import GHC.Base+#endif +#ifdef __NHC__+import Foreign.C.Types          ( CInt(..) )+#endif+ -- combined allocation and marshalling -- ----------------------------------- @@ -72,15 +75,15 @@ -- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required. -- new     :: Storable a => a -> IO (Ptr a)-new val  =-  do+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').+-- @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.@@ -93,7 +96,6 @@     return res  - -- marshalling of Boolean values (non-zero corresponds to 'True') -- ----------------------------- @@ -117,22 +119,22 @@ -- * the 'nullPtr' is used to represent 'Nothing' -- maybeNew :: (      a -> IO (Ptr a))-	 -> (Maybe 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 :: (      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'+-- '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)+                   | otherwise       = do a <- peek ptr; return (Just a)   -- marshalling lists of storable objects@@ -142,12 +144,12 @@ -- 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+         -> [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'))+                              withMany withFoo xs (\xs' -> f (x':xs'))   -- Haskellish interface to memcpy and memmove@@ -157,13 +159,15 @@ -- first (destination); the copied areas may /not/ overlap -- copyBytes               :: Ptr a -> Ptr a -> Int -> IO ()-copyBytes dest src size  = memcpy dest src (fromIntegral size)+copyBytes dest src size  = do memcpy dest src (fromIntegral size)+                              return () --- |Copies the given number of elements from the second area (source) into the+-- |Copies the given number of bytes 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)+moveBytes dest src size  = do memmove dest src (fromIntegral size)+                              return ()   -- auxilliary routines@@ -171,5 +175,5 @@  -- |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 ()+foreign import ccall unsafe "string.h" memcpy  :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)+foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
lib/base/src/Foreign/Ptr.hs view
@@ -1,65 +1,155 @@-{-# OPTIONS_LHC -N -fffi -funboxed-tuples #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Ptr+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides typed pointers to foreign data.  It is part+-- of the Foreign Function Interface (FFI) and will normally be+-- imported via the "Foreign" module.+--+----------------------------------------------------------------------------- -module Foreign.Ptr(-    Ptr(),-    nullPtr,-    castPtr,-    plusPtr,-    alignPtr,-    minusPtr,-    FunPtr(),-    nullFunPtr,-    castFunPtr,-    castFunPtrToPtr,-    castPtrToFunPtr,-    freeHaskellFunPtr-    ) where+module Foreign.Ptr ( +    -- * Data pointers -import Lhc.Show-import Lhc.Inst.Show-import Lhc.Monad-import Lhc.Order-import Lhc.IO-import Lhc.Basics-import Lhc.Num-import Lhc.Addr-import Foreign.Storable+    Ptr,      -- data Ptr a+    nullPtr,      -- :: Ptr a+    castPtr,      -- :: Ptr a -> Ptr b+    plusPtr,      -- :: Ptr a -> Int -> Ptr b+    alignPtr,     -- :: Ptr a -> Int -> Ptr a+    minusPtr,     -- :: Ptr a -> Ptr b -> Int +    -- * Function pointers -instance Show (Ptr a) where-    showsPrec n (Ptr x) = showsPrec n (toInteger (addrToWordPtr  x))+    FunPtr,      -- data FunPtr a+    nullFunPtr,      -- :: FunPtr a+    castFunPtr,      -- :: FunPtr a -> FunPtr b+    castFunPtrToPtr, -- :: FunPtr a -> Ptr b+    castPtrToFunPtr, -- :: Ptr a -> FunPtr b -nullPtr :: Ptr a-nullPtr = Ptr nullAddr+    freeHaskellFunPtr, -- :: FunPtr a -> IO ()+    -- Free the function pointer created by foreign export dynamic. -plusPtr :: Ptr a -> Int -> Ptr b-plusPtr (Ptr addr) off = Ptr (plusAddr addr off)+#ifndef __NHC__+    -- * Integral types with lossless conversion to and from pointers+    IntPtr,+    ptrToIntPtr,+    intPtrToPtr,+    WordPtr,+    ptrToWordPtr,+    wordPtrToPtr+#endif+ ) where -minusPtr :: Ptr a -> Int -> Ptr b-minusPtr (Ptr addr) off = Ptr (plusAddr addr (negate off))+#ifdef __GLASGOW_HASKELL__+import GHC.Ptr+import GHC.IOBase+import GHC.Base+import GHC.Num+import GHC.Read+import GHC.Real+import GHC.Show+import GHC.Enum+import GHC.Word         ( Word(..) ) +import Data.Int+import Data.Word+#else+import Control.Monad    ( liftM )+import Foreign.C.Types+#endif -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)) }+import Data.Bits+--import Data.Typeable+import Foreign.Storable ( Storable(..) ) +#ifdef __NHC__+import NHC.FFI+  ( Ptr+  , nullPtr+  , castPtr+  , plusPtr+  , alignPtr+  , minusPtr+  , FunPtr+  , nullFunPtr+  , castFunPtr+  , castFunPtrToPtr+  , castPtrToFunPtr+  , freeHaskellFunPtr+  )+#endif +#ifdef __HUGS__+import Hugs.Ptr+#endif -nullFunPtr = FunPtr nullFunAddr-castFunPtr (FunPtr addr) = FunPtr addr+#ifdef __GLASGOW_HASKELL__+-- | Release the storage associated with the given 'FunPtr', which+-- must have been obtained from a wrapper stub.  This should be called+-- whenever the return value from a foreign import wrapper function is+-- no longer required; otherwise, the storage it uses will leak.+foreign import ccall unsafe "freeHaskellFunctionPtr"+    freeHaskellFunPtr :: FunPtr a -> IO ()+#endif ---castFunPtrToPtr :: FunPtr a -> Ptr b---castFunPtrToPtr = unsafeCoerce+#ifndef __NHC__+# include "CTypes.h" ---castPtrToFunPtr :: Ptr a -> FunPtr b---castPtrToFunPtr = unsafeCoerce+# ifdef __GLASGOW_HASKELL__+-- | An unsigned integral type that can be losslessly converted to and from+-- @Ptr@.+newtype WordPtr = WordPtr Word deriving (Eq,Ord,Show,Num)+{-INTEGRAL_TYPE(WordPtr,tyConWordPtr,"WordPtr",Word)-}+        -- Word and Int are guaranteed pointer-sized in GHC +-- | A signed integral type that can be losslessly converted to and from+-- @Ptr@.+newtype IntPtr = IntPtr Int deriving (Eq,Ord,Show,Num)+{-INTEGRAL_TYPE(IntPtr,tyConIntPtr,"IntPtr",Int)-}+        -- Word and Int are guaranteed pointer-sized in GHC -foreign import primitive "U2U" castFunPtrToPtr :: FunPtr a -> Ptr b-foreign import primitive "U2U" castPtrToFunPtr :: Ptr a -> FunPtr b+-- | casts a @Ptr@ to a @WordPtr@+ptrToWordPtr :: Ptr a -> WordPtr+ptrToWordPtr (Ptr a#) = WordPtr (W# (int2Word# (addr2Int# a#))) +-- | casts a @WordPtr@ to a @Ptr@+wordPtrToPtr :: WordPtr -> Ptr a+wordPtrToPtr (WordPtr (W# w#)) = Ptr (int2Addr# (word2Int# w#)) +-- | casts a @Ptr@ to an @IntPtr@+ptrToIntPtr :: Ptr a -> IntPtr+ptrToIntPtr (Ptr a#) = IntPtr (I# (addr2Int# a#))++-- | casts an @IntPtr@ to a @Ptr@+intPtrToPtr :: IntPtr -> Ptr a+intPtrToPtr (IntPtr (I# i#)) = Ptr (int2Addr# i#)++# else /* !__GLASGOW_HASKELL__ */++INTEGRAL_TYPE(WordPtr,tyConWordPtr,"WordPtr",CUIntPtr)+INTEGRAL_TYPE(IntPtr,tyConIntPtr,"IntPtr",CIntPtr)++{-# CFILES cbits/PrelIOUtils.c #-}++foreign import ccall unsafe "__hscore_to_uintptr"+    ptrToWordPtr :: Ptr a -> WordPtr++foreign import ccall unsafe "__hscore_from_uintptr"+    wordPtrToPtr :: WordPtr -> Ptr a++foreign import ccall unsafe "__hscore_to_intptr"+    ptrToIntPtr :: Ptr a -> IntPtr++foreign import ccall unsafe "__hscore_from_intptr"+    intPtrToPtr :: IntPtr -> Ptr a++# endif /* !__GLASGOW_HASKELL__ */+#endif /* !__NHC_ */
lib/base/src/Foreign/StablePtr.hs view
@@ -1,49 +1,61 @@-{-# OPTIONS_LHC -N -fffi #-}-module Foreign.StablePtr(-    StablePtr(),-    castStablePtrToPtr,-    castPtrToStablePtr,-    newStablePtr,-    deRefStablePtr,-    freeStablePtr-    ) where--import Lhc.Addr-import Lhc.Basics-import Lhc.IO-import Lhc.Monad--newtype StablePtr a = StablePtr (Ptr ())-data PlaceHolder--castPtrToStablePtr :: Ptr () -> StablePtr a-castPtrToStablePtr p = StablePtr p--castStablePtrToPtr :: StablePtr a -> Ptr ()-castStablePtrToPtr (StablePtr p) = p+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.StablePtr+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- This module is part of the Foreign Function Interface (FFI) and will usually+-- be imported via the module "Foreign".+--+-----------------------------------------------------------------------------  -freeStablePtr :: StablePtr a -> IO ()-freeStablePtr _ = return ()--newStablePtr :: a -> IO (StablePtr a)-newStablePtr x = do-    ptr <- ref_ptr (unsafeCoerce x)-    return (StablePtr ptr)+module Foreign.StablePtr+        ( -- * Stable references to Haskell values+          StablePtr          -- abstract+        , newStablePtr       -- :: a -> IO (StablePtr a)+        , deRefStablePtr     -- :: StablePtr a -> IO a+        , freeStablePtr      -- :: StablePtr a -> IO ()+        , castStablePtrToPtr -- :: StablePtr a -> Ptr ()+        , castPtrToStablePtr -- :: Ptr () -> StablePtr a+        , -- ** The C-side interface -deRefStablePtr :: StablePtr a -> IO a-deRefStablePtr (StablePtr x) = do-    v <- deref_ptr x-    return (unsafeCoerce v)+          -- $cinterface+        ) where -deref_ptr = undefined-ref_ptr = undefined-unsafeCoerce = undefined+#ifdef __GLASGOW_HASKELL__+import GHC.Stable+#endif -{-+#ifdef __HUGS__+import Hugs.StablePtr+#endif -foreign import primitive deref_ptr :: Ptr () -> IO PlaceHolder-foreign import primitive ref_ptr   :: PlaceHolder -> IO (Ptr ())+#ifdef __NHC__+import NHC.FFI+  ( StablePtr+  , newStablePtr+  , deRefStablePtr+  , freeStablePtr+  , castStablePtrToPtr+  , castPtrToStablePtr+  )+#endif -foreign import primitive unsafeCoerce :: a -> b--}+-- $cinterface+--+-- The following definition is available to C programs inter-operating with+-- Haskell code when including the header @HsFFI.h@.+--+-- > typedef void *HsStablePtr;  /* C representation of a StablePtr */+--+-- Note that no assumptions may be made about the values representing stable+-- pointers.  In fact, they need not even be valid memory addresses.  The only+-- guarantee provided is that if they are passed back to Haskell land, the+-- function 'deRefStablePtr' will be able to reconstruct the+-- Haskell value referred to by the stable pointer.
lib/base/src/Foreign/Storable.hs view
@@ -1,31 +1,282 @@-{-# OPTIONS_LHC -N #-}-module Foreign.Storable(Storable(..)) where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Storable+-- Copyright   :  (c) The FFI task force 2001+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The module "Foreign.Storable" provides most elementary support for+-- marshalling and is part of the language-independent portion of the+-- Foreign Function Interface (FFI), and will normally be imported via+-- the "Foreign" module.+--+----------------------------------------------------------------------------- -import Lhc.Basics-import Lhc.Addr-import Lhc.Int-import Lhc.IO+module Foreign.Storable+        ( Storable(+             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 ()+        ) where -plusPtr :: Ptr a -> Int -> Ptr b-plusPtr (Ptr addr) off = Ptr (plusAddr addr off) +#ifdef __NHC__+import NHC.FFI (Storable(..),Ptr,FunPtr,StablePtr+               ,Int8,Int16,Int32,Int64,Word8,Word16,Word32,Word64)+#else++import Control.Monad            ( liftM )+++#ifdef __GLASGOW_HASKELL__+import GHC.Storable+import GHC.Stable       ( StablePtr )+import GHC.Num+import GHC.Int+import GHC.Word+import GHC.Ptr+import GHC.Err+import GHC.IOBase+import GHC.Base+#else+import Data.Int+import Data.Word+import Foreign.StablePtr+#endif++#ifdef __HUGS__+import Hugs.Prelude+import Hugs.Ptr+import Hugs.Storable+#endif++{- |+The member functions of this class facilitate writing values of+primitive types to raw memory (which may have been allocated with the+above mentioned routines) and reading values from blocks of raw+memory.  The class, furthermore, includes support for computing the+storage requirements and alignment restrictions of storable types.++Memory addresses are represented as values of type @'Ptr' a@, for some+@a@ which is an instance of class 'Storable'.  The type argument to+'Ptr' helps provide some valuable type safety in FFI code (you can\'t+mix pointers of different types without an explicit cast), while+helping the Haskell type system figure out which marshalling method is+needed for a given pointer.++All marshalling between Haskell and a foreign language ultimately+boils down to translating Haskell data structures into the binary+representation of a corresponding data structure of the foreign+language and vice versa.  To code this marshalling in Haskell, it is+necessary to manipulate primitive data types stored in unstructured+memory blocks.  The class 'Storable' facilitates this manipulation on+all types for which it is instantiated, which are the standard basic+types of Haskell, the fixed size @Int@ types ('Int8', 'Int16',+'Int32', 'Int64'), the fixed size @Word@ types ('Word8', 'Word16',+'Word32', 'Word64'), 'StablePtr', all types from "Foreign.C.Types",+as well as 'Ptr'.++Minimal complete definition: 'sizeOf', 'alignment', one of 'peek',+'peekElemOff' and 'peekByteOff', and one of 'poke', 'pokeElemOff' and+'pokeByteOff'.+-}+ 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 = IO $ \w -> unIO (peek $! (addr `plusPtr` (idx `times` sizeOf (_f addr)))) w-    pokeElemOff addr idx x = IO $ \w -> unIO (let adr = (addr `plusPtr` (idx `times` sizeOf x)) in adr `seq` poke adr x) w-    peekByteOff addr off = IO $ \w -> unIO (peek $! (addr `plusPtr` off)) w-    pokeByteOff addr off x = IO $ \w -> unIO (let adr = (addr `plusPtr` off) in adr `seq` poke adr x) w+   sizeOf      :: a -> Int+   -- ^ Computes the storage requirements (in bytes) of the argument.+   -- The value of the argument is not used. -_f :: Ptr a -> a-_f _ = undefined+   alignment   :: a -> Int+   -- ^ Computes the alignment constraint of the argument.  An+   -- alignment constraint @x@ is fulfilled by any address divisible+   -- by @x@.  The value of the argument is not used. +   peekElemOff :: Ptr a -> Int      -> IO a+   -- ^       Read a value from a memory area regarded as an array+   --         of values of the same kind.  The first argument specifies+   --         the start address of the array and the second the index into+   --         the array (the first element of the array has index+   --         @0@).  The following equality holds,+   -- +   -- > peekElemOff addr idx = IOExts.fixIO $ \result ->+   -- >   peek (addr `plusPtr` (idx * sizeOf result))+   --+   --         Note that this is only a specification, not+   --         necessarily the concrete implementation of the+   --         function. +   pokeElemOff :: Ptr a -> Int -> a -> IO ()+   -- ^       Write a value to a memory area regarded as an array of+   --         values of the same kind.  The following equality holds:+   -- +   -- > pokeElemOff addr idx x = +   -- >   poke (addr `plusPtr` (idx * sizeOf x)) x++   peekByteOff :: Ptr b -> Int      -> IO a+   -- ^       Read a value from a memory location given by a base+   --         address and offset.  The following equality holds:+   --+   -- > peekByteOff addr off = peek (addr `plusPtr` off)++   pokeByteOff :: Ptr b -> Int -> a -> IO ()+   -- ^       Write a value to a memory location given by a base+   --         address and offset.  The following equality holds:+   --+   -- > pokeByteOff addr off x = poke (addr `plusPtr` off) x+  +   peek        :: Ptr a      -> IO a+   -- ^ Read a value from the given memory location.+   --+   --  Note that the peek and poke functions might require properly+   --  aligned addresses to function correctly.  This is architecture+   --  dependent; thus, portable code should ensure that when peeking or+   --  poking values of some type @a@, the alignment+   --  constraint for @a@, as given by the function+   --  'alignment' is fulfilled.++   poke        :: Ptr a -> a -> IO ()+   -- ^ Write the given value to the given memory location.  Alignment+   -- restrictions might apply; see 'peek'.+ +   -- circular default instances+#ifdef __GLASGOW_HASKELL__+   peekElemOff = peekElemOff_ undefined+      where peekElemOff_ :: a -> Ptr a -> Int -> IO a+            peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)+#else+   peekElemOff ptr off = peekByteOff ptr (off * sizeOfPtr ptr undefined)+#endif+   pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val++   peekByteOff ptr off = peek (ptr `plusPtr` off)+   pokeByteOff ptr off = poke (ptr `plusPtr` off)++   peek ptr = peekElemOff ptr 0+   poke ptr = pokeElemOff ptr 0++#ifndef __GLASGOW_HASKELL__+sizeOfPtr :: Storable a => Ptr a -> a -> Int+sizeOfPtr px x = sizeOf x+#endif++-- System-dependent, but rather obvious instances++#define HTYPE_INT       Int32++#define SIZEOF_INT32    4+#define ALIGNMENT_INT32 4++#define SIZEOF_HSINT    WORD_SIZE+#define ALIGNMENT_HSINT WORD_SIZE++#define SIZEOF_HSWORD    WORD_SIZE+#define ALIGNMENT_HSWORD WORD_SIZE++#define SIZEOF_HSPTR    WORD_SIZE+#define ALIGNMENT_HSPTR WORD_SIZE++#define SIZEOF_HSFUNPTR    WORD_SIZE+#define ALIGNMENT_HSFUNPTR WORD_SIZE++#define SIZEOF_WORD8    1+#define ALIGNMENT_WORD8 1++#define SIZEOF_WORD16    2+#define ALIGNMENT_WORD16 2++#define SIZEOF_WORD32    4+#define ALIGNMENT_WORD32 4++#define SIZEOF_WORD64    8+#define ALIGNMENT_WORD64 8++#define SIZEOF_INT8    1+#define ALIGNMENT_INT8 1++#define SIZEOF_INT16    2+#define ALIGNMENT_INT16 2++#define SIZEOF_INT32    4+#define ALIGNMENT_INT32 4++#define SIZEOF_INT64    8+#define ALIGNMENT_INT64 8++instance Storable Bool where+   sizeOf _          = sizeOf (undefined::HTYPE_INT)+   alignment _       = alignment (undefined::HTYPE_INT)+   peekElemOff p i   = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i+   pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT)++#define STORABLE(T,size,align,read,write)       \+instance Storable (T) where {                   \+    sizeOf    _ = size;                         \+    alignment _ = align;                        \+    peekElemOff = read;                         \+    pokeElemOff = write }++#ifdef __GLASGOW_HASKELL__+STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,+         readWideCharOffPtr,writeWideCharOffPtr)+#elif defined(__HUGS__)+STORABLE(Char,SIZEOF_HSCHAR,ALIGNMENT_HSCHAR,+         readCharOffPtr,writeCharOffPtr)+#endif++STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT,+         readIntOffPtr,writeIntOffPtr)++#ifndef __NHC__+STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD,+         readWordOffPtr,writeWordOffPtr)+#endif++STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR,+         readPtrOffPtr,writePtrOffPtr)++STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR,+         readFunPtrOffPtr,writeFunPtrOffPtr)+{-+STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR,+         readStablePtrOffPtr,writeStablePtrOffPtr)++STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT,+         readFloatOffPtr,writeFloatOffPtr)++STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE,+         readDoubleOffPtr,writeDoubleOffPtr)+-}+STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,+         readWord8OffPtr,writeWord8OffPtr)++STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,+         readWord16OffPtr,writeWord16OffPtr)++STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,+         readWord32OffPtr,writeWord32OffPtr)++STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,+         readWord64OffPtr,writeWord64OffPtr)++STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,+         readInt8OffPtr,writeInt8OffPtr)++STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,+         readInt16OffPtr,writeInt16OffPtr)++STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,+         readInt32OffPtr,writeInt32OffPtr)+STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,+         readInt64OffPtr,writeInt64OffPtr)++#endif
+ lib/base/src/Foreign/Storable.hs-boot view
@@ -0,0 +1,22 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module Foreign.Storable where++import GHC.Base+import GHC.Int+import GHC.Word++class Storable a++instance Storable Int8+instance Storable Int16+instance Storable Int32+instance Storable Int64+instance Storable Word8+instance Storable Word16+instance Storable Word32+instance Storable Word64+--instance Storable Float+--instance Storable Double+
− lib/base/src/Foreign/Storable.m4 
@@ -1,21 +0,0 @@---m4_define(INST_STORABLE,{{--instance Storable $1 where-    peek (Ptr (Addr addr)) = IO $ \w -> case peek$2 addr w of-        (# w', r #) -> (# w', $1 r #)-    poke (Ptr (Addr addr)) ($1 v) = IO $ \w -> case poke$2 addr v w of-        w' -> (# w', () #)-    sizeOf _ = boxInt (sizeOf$2 0#)-    alignment _ = boxInt (alignmentOf$2 0#)--ONCE({{-foreign import primitive "peek.$3" peek$2 :: Addr__ -> UIO $2-foreign import primitive "poke.$3" poke$2 :: Addr__ -> $2 -> UIO_-foreign import primitive "sizeOf.$3" sizeOf$2 :: $2 -> Int__-foreign import primitive "alignmentOf.$3" alignmentOf$2 :: $2 -> Int__-}})--}})-
+ lib/base/src/GHC/Arr.lhs view
@@ -0,0 +1,729 @@+\begin{code}+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# LANGUAGE NoImplicitPrelude, NoBangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Arr+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC\'s array implementation.+-- +-----------------------------------------------------------------------------++module GHC.Arr where++import GHC.Enum+import GHC.Num+import GHC.ST+import GHC.Base+import GHC.List+import GHC.Show++infixl 9  !, //++default ()+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Ix@ class}+%*                                                      *+%*********************************************************++\begin{code}+-- | The 'Ix' class is used to map a contiguous subrange of values in+-- a type onto integers.  It is used primarily for array indexing+-- (see the array package).+--+-- The first argument @(l,u)@ of each of these operations is a pair+-- specifying the lower and upper bounds of a contiguous subrange of values.+--+-- An implementation is entitled to assume the following laws about these+-- operations:+--+-- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@+--+-- * @'range' (l,u) '!!' 'index' (l,u) i == i@, when @'inRange' (l,u) i@+--+-- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@+--+-- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@+--+-- Minimal complete instance: 'range', 'index' and 'inRange'.+--+class (Ord a) => Ix a where+    -- | The list of values in the subrange defined by a bounding pair.+    range               :: (a,a) -> [a]+    -- | The position of a subscript in the subrange.+    index               :: (a,a) -> a -> Int+    -- | Like 'index', but without checking that the value is in range.+    unsafeIndex         :: (a,a) -> a -> Int+    -- | Returns 'True' the given subscript lies in the range defined+    -- the bounding pair.+    inRange             :: (a,a) -> a -> Bool+    -- | The size of the subrange defined by a bounding pair.+    rangeSize           :: (a,a) -> Int+    -- | like 'rangeSize', but without checking that the upper bound is+    -- in range.+    unsafeRangeSize     :: (a,a) -> Int++        -- Must specify one of index, unsafeIndex+    index b i | inRange b i = unsafeIndex b i   +              | otherwise   = error "Error in array index"+    unsafeIndex b i = index b i++    rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1+                       | otherwise   = 0        -- This case is only here to+                                                -- check for an empty range+        -- NB: replacing (inRange b h) by (l <= h) fails for+        --     tuples.  E.g.  (1,2) <= (2,1) but the range is empty++    unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1+\end{code}++Note that the following is NOT right+        rangeSize (l,h) | l <= h    = index b h + 1+                        | otherwise = 0++Because it might be the case that l<h, but the range+is nevertheless empty.  Consider+        ((1,2),(2,1))+Here l<h, but the second index ranges from 2..1 and+hence is empty++%*********************************************************+%*                                                      *+\subsection{Instances of @Ix@}+%*                                                      *+%*********************************************************++\begin{code}+-- abstract these errors from the relevant index functions so that+-- the guts of the function will be small enough to inline.++{-# NOINLINE indexError #-}+indexError :: Show a => (a,a) -> a -> String -> b+indexError rng i tp+  = error (showString "Ix{" . showString tp . showString "}.index: Index " .+           showParen True (showsPrec 0 i) .+           showString " out of range " $+           showParen True (showsPrec 0 rng) "")++----------------------------------------------------------------------+instance  Ix Char  where+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (m,_n) i = fromEnum i - fromEnum m++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Char"++    inRange (m,n) i     =  m <= i && i <= n++----------------------------------------------------------------------+instance  Ix Int  where+    {-# INLINE range #-}+        -- The INLINE stops the build in the RHS from getting inlined,+        -- so that callers can fuse with the result of range+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (m,_n) i = i - m++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Int"++    {-# INLINE inRange #-}+    inRange (I# m,I# n) (I# i) =  m <=# i && i <=# n++----------------------------------------------------------------------+instance  Ix Integer  where+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (m,_n) i   = fromInteger (i - m)++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Integer"++    inRange (m,n) i     =  m <= i && i <= n++----------------------------------------------------------------------+instance Ix Bool where -- as derived+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (l,_) i = fromEnum i - fromEnum l++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Bool"++    inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u++----------------------------------------------------------------------+instance Ix Ordering where -- as derived+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (l,_) i = fromEnum i - fromEnum l++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Ordering"++    inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u++----------------------------------------------------------------------+instance Ix () where+    {-# INLINE range #-}+    range   ((), ())    = [()]+    {-# INLINE unsafeIndex #-}+    unsafeIndex   ((), ()) () = 0+    {-# INLINE inRange #-}+    inRange ((), ()) () = True+    {-# INLINE index #-}+    index b i = unsafeIndex b i++----------------------------------------------------------------------+instance (Ix a, Ix b) => Ix (a, b) where -- as derived+    {-# SPECIALISE instance Ix (Int,Int) #-}++    {-# INLINE range #-}+    range ((l1,l2),(u1,u2)) =+      [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ]++    {-# INLINE unsafeIndex #-}+    unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) =+      unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2++    {-# INLINE inRange #-}+    inRange ((l1,l2),(u1,u2)) (i1,i2) =+      inRange (l1,u1) i1 && inRange (l2,u2) i2++    -- Default method for index++----------------------------------------------------------------------+instance  (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3)  where+    {-# SPECIALISE instance Ix (Int,Int,Int) #-}++    range ((l1,l2,l3),(u1,u2,u3)) =+        [(i1,i2,i3) | i1 <- range (l1,u1),+                      i2 <- range (l2,u2),+                      i3 <- range (l3,u3)]++    unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =+      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (+      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (+      unsafeIndex (l1,u1) i1))++    inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =+      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&+      inRange (l3,u3) i3++    -- Default method for index++----------------------------------------------------------------------+instance  (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4)  where+    range ((l1,l2,l3,l4),(u1,u2,u3,u4)) =+      [(i1,i2,i3,i4) | i1 <- range (l1,u1),+                       i2 <- range (l2,u2),+                       i3 <- range (l3,u3),+                       i4 <- range (l4,u4)]++    unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =+      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (+      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (+      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (+      unsafeIndex (l1,u1) i1)))++    inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =+      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&+      inRange (l3,u3) i3 && inRange (l4,u4) i4++    -- Default method for index++instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5)  where+    range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) =+      [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1),+                          i2 <- range (l2,u2),+                          i3 <- range (l3,u3),+                          i4 <- range (l4,u4),+                          i5 <- range (l5,u5)]++    unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =+      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (+      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (+      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (+      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (+      unsafeIndex (l1,u1) i1))))++    inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =+      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&+      inRange (l3,u3) i3 && inRange (l4,u4) i4 && +      inRange (l5,u5) i5++    -- Default method for index+\end{code}++%*********************************************************+%*                                                      *+\subsection{The @Array@ types}+%*                                                      *+%*********************************************************++\begin{code}+type IPr = (Int, Int)++-- | The type of immutable non-strict (boxed) arrays+-- with indices in @i@ and elements in @e@.+-- The Int is the number of elements in the Array.+data Ix i => Array i e+                 = Array !i         -- the lower bound, l+                         !i         -- the upper bound, u+                         !Int       -- a cache of (rangeSize (l,u))+                                    -- used to make sure an index is+                                    -- really in range+                         (Array# e) -- The actual elements++-- | Mutable, boxed, non-strict arrays in the 'ST' monad.  The type+-- arguments are as follows:+--+--  * @s@: the state variable argument for the 'ST' type+--+--  * @i@: the index type of the array (should be an instance of 'Ix')+--+--  * @e@: the element type of the array.+--+data STArray s i e+         = STArray !i                  -- the lower bound, l+                   !i                  -- the upper bound, u+                   !Int                -- a cache of (rangeSize (l,u))+                                       -- used to make sure an index is+                                       -- really in range+                   (MutableArray# s e) -- The actual elements+        -- No Ix context for STArray.  They are stupid,+        -- and force an Ix context on the equality instance.++-- Just pointer equality on mutable arrays:+instance Eq (STArray s i e) where+    STArray _ _ _ arr1# == STArray _ _ _ arr2# =+        sameMutableArray# arr1# arr2#+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Operations on immutable arrays}+%*                                                      *+%*********************************************************++\begin{code}+{-# NOINLINE arrEleBottom #-}+arrEleBottom :: a+arrEleBottom = error "(Array.!): undefined array element"++{-# INLINE array #-}+-- | Construct an array with the specified bounds and containing values+-- for given indices within these bounds.+--+-- The array is undefined (i.e. bottom) if any index in the list is+-- out of bounds.  The Haskell 98 Report further specifies that if any+-- two associations in the list have the same index, the value at that+-- index is undefined (i.e. bottom).  However in GHC's implementation,+-- the value at such an index is the value part of the last association+-- with that index in the list.+--+-- Because the indices must be checked for these errors, 'array' is+-- strict in the bounds argument and in the indices of the association+-- list, but nonstrict in the values.  Thus, recurrences such as the+-- following are possible:+--+-- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]])+--+-- Not every index within the bounds of the array need appear in the+-- association list, but the values associated with indices that do not+-- appear will be undefined (i.e. bottom).+--+-- If, in any dimension, the lower bound is greater than the upper bound,+-- then the array is legal, but empty.  Indexing an empty array always+-- gives an array-bounds error, but 'bounds' still yields the bounds+-- with which the array was constructed.+array :: Ix i+        => (i,i)        -- ^ a pair of /bounds/, each of the index type+                        -- of the array.  These bounds are the lowest and+                        -- highest indices in the array, in that order.+                        -- For example, a one-origin vector of length+                        -- '10' has bounds '(1,10)', and a one-origin '10'+                        -- by '10' matrix has bounds '((1,1),(10,10))'.+        -> [(i, e)]     -- ^ a list of /associations/ of the form+                        -- (/index/, /value/).  Typically, this list will+                        -- be expressed as a comprehension.  An+                        -- association '(i, x)' defines the value of+                        -- the array at index 'i' to be 'x'.+        -> Array i e+array (l,u) ies+    = let n = safeRangeSize (l,u)+      in unsafeArray' (l,u) n+                      [(safeIndex (l,u) n i, e) | (i, e) <- ies]++{-# INLINE unsafeArray #-}+unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e+unsafeArray b ies = unsafeArray' b (rangeSize b) ies++{-# INLINE unsafeArray' #-}+unsafeArray' :: Ix i => (i,i) -> Int -> [(Int, e)] -> Array i e+unsafeArray' (l,u) n@(I# n#) ies = runST (ST $ \s1# ->+    case newArray# n# arrEleBottom s1# of+        (# s2#, marr# #) ->+            foldr (fill marr#) (done l u n marr#) ies s2#)++{-# INLINE fill #-}+fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a+fill marr# (I# i#, e) next s1# =+    case writeArray# marr# i# e s1#     of { s2# ->+    next s2# }++{-# INLINE done #-}+done :: Ix i => i -> i -> Int -> MutableArray# s e -> STRep s (Array i e)+done l u n marr# s1# =+    case unsafeFreezeArray# marr# s1# of+        (# s2#, arr# #) -> (# s2#, Array l u n arr# #)++-- This is inefficient and I'm not sure why:+-- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)+-- The code below is better. It still doesn't enable foldr/build+-- transformation on the list of elements; I guess it's impossible+-- using mechanisms currently available.++{-# INLINE listArray #-}+-- | Construct an array from a pair of bounds and a list of values in+-- index order.+listArray :: Ix i => (i,i) -> [e] -> Array i e+listArray (l,u) es = runST (ST $ \s1# ->+    case safeRangeSize (l,u)            of { n@(I# n#) ->+    case newArray# n# arrEleBottom s1#  of { (# s2#, marr# #) ->+    let fillFromList i# xs s3# | i# ==# n# = s3#+                               | otherwise = case xs of+            []   -> s3#+            y:ys -> case writeArray# marr# i# y s3# of { s4# ->+                    fillFromList (i# +# 1#) ys s4# } in+    case fillFromList 0# es s2#         of { s3# ->+    done l u n marr# s3# }}})++{-# INLINE (!) #-}+-- | The value at the given index in an array.+(!) :: Ix i => Array i e -> i -> e+arr@(Array l u n _) ! i = unsafeAt arr $ safeIndex (l,u) n i++{-# INLINE safeRangeSize #-}+safeRangeSize :: Ix i => (i, i) -> Int+safeRangeSize (l,u) = let r = rangeSize (l, u)+                      in if r < 0 then error "Negative range size"+                                  else r++{-# INLINE safeIndex #-}+safeIndex :: Ix i => (i, i) -> Int -> i -> Int+safeIndex (l,u) n i = let i' = unsafeIndex (l,u) i+                      in if (0 <= i') && (i' < n)+                         then i'+                         else error "Error in array index"++{-# INLINE unsafeAt #-}+unsafeAt :: Ix i => Array i e -> Int -> e+unsafeAt (Array _ _ _ arr#) (I# i#) =+    case indexArray# arr# i# of (# e #) -> e++{-# INLINE bounds #-}+-- | The bounds with which an array was constructed.+bounds :: Ix i => Array i e -> (i,i)+bounds (Array l u _ _) = (l,u)++{-# INLINE numElements #-}+-- | The number of elements in the array.+numElements :: Ix i => Array i e -> Int+numElements (Array _ _ n _) = n++{-# INLINE indices #-}+-- | The list of indices of an array in ascending order.+indices :: Ix i => Array i e -> [i]+indices (Array l u _ _) = range (l,u)++{-# INLINE elems #-}+-- | The list of elements of an array in index order.+elems :: Ix i => Array i e -> [e]+elems arr@(Array _ _ n _) =+    [unsafeAt arr i | i <- [0 .. n - 1]]++{-# INLINE assocs #-}+-- | The list of associations of an array in index order.+assocs :: Ix i => Array i e -> [(i, e)]+assocs arr@(Array l u _ _) =+    [(i, arr ! i) | i <- range (l,u)]++{-# INLINE accumArray #-}+-- | The 'accumArray' deals with repeated indices in the association+-- list using an /accumulating function/ which combines the values of+-- associations with the same index.+-- For example, given a list of values of some index type, @hist@+-- produces a histogram of the number of occurrences of each index within+-- a specified range:+--+-- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b+-- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i]+--+-- If the accumulating function is strict, then 'accumArray' is strict in+-- the values, as well as the indices, in the association list.  Thus,+-- unlike ordinary arrays built with 'array', accumulated arrays should+-- not in general be recursive.+accumArray :: Ix i+        => (e -> a -> e)        -- ^ accumulating function+        -> e                    -- ^ initial value+        -> (i,i)                -- ^ bounds of the array+        -> [(i, a)]             -- ^ association list+        -> Array i e+accumArray f initial (l,u) ies =+    let n = safeRangeSize (l,u)+    in unsafeAccumArray' f initial (l,u) n+                         [(safeIndex (l,u) n i, e) | (i, e) <- ies]++{-# INLINE unsafeAccumArray #-}+unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e+unsafeAccumArray f initial b ies = unsafeAccumArray' f initial b (rangeSize b) ies++{-# INLINE unsafeAccumArray' #-}+unsafeAccumArray' :: Ix i => (e -> a -> e) -> e -> (i,i) -> Int -> [(Int, a)] -> Array i e+unsafeAccumArray' f initial (l,u) n@(I# n#) ies = runST (ST $ \s1# ->+    case newArray# n# initial s1#          of { (# s2#, marr# #) ->+    foldr (adjust f marr#) (done l u n marr#) ies s2# })++{-# INLINE adjust #-}+adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b+adjust f marr# (I# i#, new) next s1# =+    case readArray# marr# i# s1# of+        (# s2#, old #) ->+            case writeArray# marr# i# (f old new) s2# of+                s3# -> next s3#++{-# INLINE (//) #-}+-- | Constructs an array identical to the first argument except that it has+-- been updated by the associations in the right argument.+-- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then+--+-- > m//[((i,i), 0) | i <- [1..n]]+--+-- is the same matrix, except with the diagonal zeroed.+--+-- Repeated indices in the association list are handled as for 'array':+-- Haskell 98 specifies that the resulting array is undefined (i.e. bottom),+-- but GHC's implementation uses the last association for each index.+(//) :: Ix i => Array i e -> [(i, e)] -> Array i e+arr@(Array l u n _) // ies =+    unsafeReplace arr [(safeIndex (l,u) n i, e) | (i, e) <- ies]++{-# INLINE unsafeReplace #-}+unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e+unsafeReplace arr ies = runST (do+    STArray l u n marr# <- thawSTArray arr+    ST (foldr (fill marr#) (done l u n marr#) ies))++{-# INLINE accum #-}+-- | @'accum' f@ takes an array and an association list and accumulates+-- pairs from the list into the array with the accumulating function @f@.+-- Thus 'accumArray' can be defined using 'accum':+--+-- > accumArray f z b = accum f (array b [(i, z) | i <- range b])+--+accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e+accum f arr@(Array l u n _) ies =+    unsafeAccum f arr [(safeIndex (l,u) n i, e) | (i, e) <- ies]++{-# INLINE unsafeAccum #-}+unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e+unsafeAccum f arr ies = runST (do+    STArray l u n marr# <- thawSTArray arr+    ST (foldr (adjust f marr#) (done l u n marr#) ies))++{-# INLINE amap #-}+amap :: Ix i => (a -> b) -> Array i a -> Array i b+amap f arr@(Array l u n _) =+    unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]]++{-# INLINE ixmap #-}+-- | 'ixmap' allows for transformations on array indices.+-- It may be thought of as providing function composition on the right+-- with the mapping that the original array embodies.+--+-- A similar transformation of array values may be achieved using 'fmap'+-- from the 'Array' instance of the 'Functor' class.+ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e+ixmap (l,u) f arr =+    array (l,u) [(i, arr ! f i) | i <- range (l,u)]++{-# INLINE eqArray #-}+eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool+eqArray arr1@(Array l1 u1 n1 _) arr2@(Array l2 u2 n2 _) =+    if n1 == 0 then n2 == 0 else+    l1 == l2 && u1 == u2 &&+    and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. n1 - 1]]++{-# INLINE cmpArray #-}+cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering+cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2)++{-# INLINE cmpIntArray #-}+cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering+cmpIntArray arr1@(Array l1 u1 n1 _) arr2@(Array l2 u2 n2 _) =+    if n1 == 0 then+        if n2 == 0 then EQ else LT+    else if n2 == 0 then GT+    else case compare l1 l2 of+             EQ    -> foldr cmp (compare u1 u2) [0 .. (n1 `min` n2) - 1]+             other -> other+  where+    cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of+        EQ    -> rest+        other -> other++{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-}+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Array instances}+%*                                                      *+%*********************************************************++\begin{code}+instance Ix i => Functor (Array i) where+    fmap = amap++instance (Ix i, Eq e) => Eq (Array i e) where+    (==) = eqArray++instance (Ix i, Ord e) => Ord (Array i e) where+    compare = cmpArray++instance (Ix a, Show a, Show b) => Show (Array a b) where+    showsPrec p a =+        showParen (p > appPrec) $+        showString "array " .+        showsPrec appPrec1 (bounds a) .+        showChar ' ' .+        showsPrec appPrec1 (assocs a)+        -- Precedence of 'array' is the precedence of application++-- The Read instance is in GHC.Read+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Operations on mutable arrays}+%*                                                      *+%*********************************************************++Idle ADR question: What's the tradeoff here between flattening these+datatypes into @STArray ix ix (MutableArray# s elt)@ and using+it as is?  As I see it, the former uses slightly less heap and+provides faster access to the individual parts of the bounds while the+code used has the benefit of providing a ready-made @(lo, hi)@ pair as+required by many array-related functions.  Which wins? Is the+difference significant (probably not).++Idle AJG answer: When I looked at the outputted code (though it was 2+years ago) it seems like you often needed the tuple, and we build+it frequently. Now we've got the overloading specialiser things+might be different, though.++\begin{code}+{-# INLINE newSTArray #-}+newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)+newSTArray (l,u) initial = ST $ \s1# ->+    case safeRangeSize (l,u)            of { n@(I# n#) ->+    case newArray# n# initial s1#       of { (# s2#, marr# #) ->+    (# s2#, STArray l u n marr# #) }}++{-# INLINE boundsSTArray #-}+boundsSTArray :: STArray s i e -> (i,i)  +boundsSTArray (STArray l u _ _) = (l,u)++{-# INLINE numElementsSTArray #-}+numElementsSTArray :: STArray s i e -> Int+numElementsSTArray (STArray _ _ n _) = n++{-# INLINE readSTArray #-}+readSTArray :: Ix i => STArray s i e -> i -> ST s e+readSTArray marr@(STArray l u n _) i =+    unsafeReadSTArray marr (safeIndex (l,u) n i)++{-# INLINE unsafeReadSTArray #-}+unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e+unsafeReadSTArray (STArray _ _ _ marr#) (I# i#)+    = ST $ \s1# -> readArray# marr# i# s1#++{-# INLINE writeSTArray #-}+writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () +writeSTArray marr@(STArray l u n _) i e =+    unsafeWriteSTArray marr (safeIndex (l,u) n i) e++{-# INLINE unsafeWriteSTArray #-}+unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s () +unsafeWriteSTArray (STArray _ _ _ marr#) (I# i#) e = ST $ \s1# ->+    case writeArray# marr# i# e s1# of+        s2# -> (# s2#, () #)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Moving between mutable and immutable}+%*                                                      *+%*********************************************************++\begin{code}+freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)+freezeSTArray (STArray l u n@(I# n#) marr#) = ST $ \s1# ->+    case newArray# n# arrEleBottom s1#  of { (# s2#, marr'# #) ->+    let copy i# s3# | i# ==# n# = s3#+                    | otherwise =+            case readArray# marr# i# s3# of { (# s4#, e #) ->+            case writeArray# marr'# i# e s4# of { s5# ->+            copy (i# +# 1#) s5# }} in+    case copy 0# s2#                    of { s3# ->+    case unsafeFreezeArray# marr'# s3#  of { (# s4#, arr# #) ->+    (# s4#, Array l u n arr# #) }}}++{-# INLINE unsafeFreezeSTArray #-}+unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)+unsafeFreezeSTArray (STArray l u n marr#) = ST $ \s1# ->+    case unsafeFreezeArray# marr# s1#   of { (# s2#, arr# #) ->+    (# s2#, Array l u n arr# #) }++thawSTArray :: Ix i => Array i e -> ST s (STArray s i e)+thawSTArray (Array l u n@(I# n#) arr#) = ST $ \s1# ->+    case newArray# n# arrEleBottom s1#  of { (# s2#, marr# #) ->+    let copy i# s3# | i# ==# n# = s3#+                    | otherwise =+            case indexArray# arr# i#    of { (# e #) ->+            case writeArray# marr# i# e s3# of { s4# ->+            copy (i# +# 1#) s4# }} in+    case copy 0# s2#                    of { s3# ->+    (# s3#, STArray l u n marr# #) }}++{-# INLINE unsafeThawSTArray #-}+unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e)+unsafeThawSTArray (Array l u n arr#) = ST $ \s1# ->+    case unsafeThawArray# arr# s1#      of { (# s2#, marr# #) ->+    (# s2#, STArray l u n marr# #) }+\end{code}
+ lib/base/src/GHC/Base.lhs view
@@ -0,0 +1,1006 @@+\section[GHC.Base]{Module @GHC.Base@}++The overall structure of the GHC Prelude is a bit tricky.++  a) We want to avoid "orphan modules", i.e. ones with instance+        decls that don't belong either to a tycon or a class+        defined in the same module++  b) We want to avoid giant modules++So the rough structure is as follows, in (linearised) dependency order+++GHC.Prim                Has no implementation.  It defines built-in things, and+                by importing it you bring them into scope.+                The source file is GHC.Prim.hi-boot, which is just+                copied to make GHC.Prim.hi++GHC.Base        Classes: Eq, Ord, Functor, Monad+                Types:   list, (), Int, Bool, Ordering, Char, String++Data.Tuple      Types: tuples, plus instances for GHC.Base classes++GHC.Show        Class: Show, plus instances for GHC.Base/GHC.Tup types++GHC.Enum        Class: Enum,  plus instances for GHC.Base/GHC.Tup types++Data.Maybe      Type: Maybe, plus instances for GHC.Base classes++GHC.List        List functions++GHC.Num         Class: Num, plus instances for Int+                Type:  Integer, plus instances for all classes so far (Eq, Ord, Num, Show)++                Integer is needed here because it is mentioned in the signature+                of 'fromInteger' in class Num++GHC.Real        Classes: Real, Integral, Fractional, RealFrac+                         plus instances for Int, Integer+                Types:  Ratio, Rational+                        plus intances for classes so far++                Rational is needed here because it is mentioned in the signature+                of 'toRational' in class Real++GHC.ST  The ST monad, instances and a few helper functions++Ix              Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples++GHC.Arr         Types: Array, MutableArray, MutableVar++                Arrays are used by a function in GHC.Float++GHC.Float       Classes: Floating, RealFloat+                Types:   Float, Double, plus instances of all classes so far++                This module contains everything to do with floating point.+                It is a big module (900 lines)+                With a bit of luck, many modules can be compiled without ever reading GHC.Float.hi+++Other Prelude modules are much easier with fewer complex dependencies.++\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Base+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic data types and classes.+-- +-----------------------------------------------------------------------------++#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#)++-- #hide+module GHC.Base+        (+        module GHC.Base,+        module GHC.Bool,+        module GHC.Classes,+        module GHC.Generics,+        module GHC.Ordering,+        module GHC.Types,+        module GHC.Prim,        -- Re-export GHC.Prim and GHC.Err, to avoid lots+        module GHC.Err          -- of people having to import it explicitly+  ) +        where++import GHC.Types+import GHC.Bool+import GHC.Classes+import GHC.Generics+import GHC.Ordering+import GHC.Prim+import {-# SOURCE #-} GHC.Err++infixr 9  .+infixr 5  +++infixl 1  >>, >>=+infixr 0  $++default ()              -- Double isn't available yet+\end{code}+++%*********************************************************+%*                                                      *+\subsection{DEBUGGING STUFF}+%*  (for use when compiling GHC.Base itself doesn't work)+%*                                                      *+%*********************************************************++\begin{code}+{-+data  Bool  =  False | True+data Ordering = LT | EQ | GT +data Char = C# Char#+type  String = [Char]+data Int = I# Int#+data  ()  =  ()+data [] a = MkNil++not True = False+(&&) True True = True+otherwise = True++build = error "urk"+foldr = error "urk"++unpackCString# :: Addr# -> [Char]+unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a +unpackAppendCString# :: Addr# -> [Char] -> [Char]+unpackCStringUtf8# :: Addr# -> [Char]+unpackCString# a = error "urk"+unpackFoldrCString# a = error "urk"+unpackAppendCString# a = error "urk"+unpackCStringUtf8# a = error "urk"+-}+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Monadic classes @Functor@, @Monad@ }+%*                                                      *+%*********************************************************++\begin{code}+{- | The 'Functor' class is used for types that can be mapped over.+Instances of 'Functor' should satisfy the following laws:++> fmap id  ==  id+> fmap (f . g)  ==  fmap f . fmap g++The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+defined in the "Prelude" satisfy these laws.+-}++class  Functor f  where+    fmap        :: (a -> b) -> f a -> f b++{- | The 'Monad' class defines the basic operations over a /monad/,+a concept from a branch of mathematics known as /category theory/.+From the perspective of a Haskell programmer, however, it is best to+think of a monad as an /abstract datatype/ of actions.+Haskell's @do@ expressions provide a convenient syntax for writing+monadic expressions.++Minimal complete definition: '>>=' and 'return'.++Instances of 'Monad' should satisfy the following laws:++> return a >>= k  ==  k a+> m >>= return  ==  m+> m >>= (\x -> k x >>= h)  ==  (m >>= k) >>= h++Instances of both 'Monad' and 'Functor' should additionally satisfy the law:++> fmap f xs  ==  xs >>= return . f++The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+defined in the "Prelude" satisfy these laws.+-}++class  Monad m  where+    -- | Sequentially compose two actions, passing any value produced+    -- by the first as an argument to the second.+    (>>=)       :: forall a b. m a -> (a -> m b) -> m b+    -- | Sequentially compose two actions, discarding any value produced+    -- by the first, like sequencing operators (such as the semicolon)+    -- in imperative languages.+    (>>)        :: forall a b. m a -> m b -> m b+        -- Explicit for-alls so that we know what order to+        -- give type arguments when desugaring++    -- | Inject a value into the monadic type.+    return      :: a -> m a+    -- | Fail with a message.  This operation is not part of the+    -- mathematical definition of a monad, but is invoked on pattern-match+    -- failure in a @do@ expression.+    fail        :: String -> m a++    m >> k      = m >>= \_ -> k+    fail s      = error s+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The list type}+%*                                                      *+%*********************************************************++\begin{code}+-- do explicitly: deriving (Eq, Ord)+-- to avoid weird names like con2tag_[]#++instance (Eq a) => Eq [a] where+    {-# SPECIALISE instance Eq [Char] #-}+    []     == []     = True+    (x:xs) == (y:ys) = x == y && xs == ys+    _xs    == _ys    = False++instance (Ord a) => Ord [a] where+    {-# SPECIALISE instance Ord [Char] #-}+    compare []     []     = EQ+    compare []     (_:_)  = LT+    compare (_:_)  []     = GT+    compare (x:xs) (y:ys) = case compare x y of+                                EQ    -> compare xs ys+                                other -> other++instance Functor [] where+    fmap = map++instance  Monad []  where+    m >>= k             = foldr ((++) . k) [] m+    m >> k              = foldr ((++) . (\ _ -> k)) [] m+    return x            = [x]+    fail _              = []+\end{code}++A few list functions that appear here because they are used here.+The rest of the prelude list functions are in GHC.List.++----------------------------------------------+--      foldr/build/augment+----------------------------------------------+  +\begin{code}+-- | 'foldr', applied to a binary operator, a starting value (typically+-- the right-identity of the operator), and a list, reduces the list+-- using the binary operator, from right to left:+--+-- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)++foldr            :: (a -> b -> b) -> b -> [a] -> b+-- foldr _ z []     =  z+-- foldr f z (x:xs) =  f x (foldr f z xs)+{-# INLINE [0] foldr #-}+-- Inline only in the final stage, after the foldr/cons rule has had a chance+foldr k z xs = go xs+             where+               go []     = z+               go (y:ys) = y `k` go ys++-- | A list producer that can be fused with 'foldr'.+-- This function is merely+--+-- >    build g = g (:) []+--+-- but GHC's simplifier will transform an expression of the form+-- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@,+-- which avoids producing an intermediate list.++build   :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]+{-# INLINE [1] build #-}+        -- The INLINE is important, even though build is tiny,+        -- because it prevents [] getting inlined in the version that+        -- appears in the interface file.  If [] *is* inlined, it+        -- won't match with [] appearing in rules in an importing module.+        --+        -- The "1" says to inline in phase 1++build g = g (:) []++-- | A list producer that can be fused with 'foldr'.+-- This function is merely+--+-- >    augment g xs = g (:) xs+--+-- but GHC's simplifier will transform an expression of the form+-- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to+-- @g k ('foldr' k z xs)@, which avoids producing an intermediate list.++augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]+{-# INLINE [1] augment #-}+augment g xs = g (:) xs++{-# RULES+"fold/build"    forall k z (g::forall b. (a->b->b) -> b -> b) . +                foldr k z (build g) = g k z++"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)++"foldr/id"                        foldr (:) [] = \x  -> x+"foldr/app"     [1] forall ys. foldr (:) ys = \xs -> xs ++ ys+        -- Only activate this from phase 1, because that's+        -- when we disable the rule that expands (++) into foldr++-- The foldr/cons rule looks nice, but it can give disastrously+-- bloated code when commpiling+--      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]+-- i.e. when there are very very long literal lists+-- So I've disabled it for now. We could have special cases+-- for short lists, I suppose.+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)++"foldr/single"  forall k z x. foldr k z [x] = k x z+"foldr/nil"     forall k z.   foldr k z []  = z ++"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))+"augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .+                        augment g [] = build g+ #-}++-- This rule is true, but not (I think) useful:+--      augment g (augment h t) = augment (\cn -> g c (h c n)) t+\end{code}+++----------------------------------------------+--              map     +----------------------------------------------++\begin{code}+-- | 'map' @f xs@ is the list obtained by applying @f@ to each element+-- of @xs@, i.e.,+--+-- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]+-- > map f [x1, x2, ...] == [f x1, f x2, ...]++map :: (a -> b) -> [a] -> [b]+map _ []     = []+map f (x:xs) = f x : map f xs++-- Note eta expanded+mapFB ::  (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst+{-# INLINE [0] mapFB #-}+mapFB c f x ys = c (f x) ys++-- The rules for map work like this.+-- +-- Up to (but not including) phase 1, we use the "map" rule to+-- rewrite all saturated applications of map with its build/fold +-- form, hoping for fusion to happen.+-- In phase 1 and 0, we switch off that rule, inline build, and+-- switch on the "mapList" rule, which rewrites the foldr/mapFB+-- thing back into plain map.  +--+-- It's important that these two rules aren't both active at once +-- (along with build's unfolding) else we'd get an infinite loop +-- in the rules.  Hence the activation control below.+--+-- The "mapFB" rule optimises compositions of map.+--+-- This same pattern is followed by many other functions: +-- e.g. append, filter, iterate, repeat, etc.++{-# RULES+"map"       [~1] forall f xs.   map f xs                = build (\c n -> foldr (mapFB c f) n xs)+"mapList"   [1]  forall f.      foldr (mapFB (:) f) []  = map f+"mapFB"     forall c f g.       mapFB (mapFB c f) g     = mapFB c (f.g) +  #-}+\end{code}+++----------------------------------------------+--              append  +----------------------------------------------+\begin{code}+-- | Append two lists, i.e.,+--+-- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn]+-- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...]+--+-- If the first list is not finite, the result is the first list.++(++) :: [a] -> [a] -> [a]+(++) []     ys = ys+(++) (x:xs) ys = x : xs ++ ys++{-# RULES+"++"    [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys+  #-}++\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Bool@}+%*                                                      *+%*********************************************************++\begin{code}+-- |The 'Bool' type is an enumeration.  It is defined with 'False'+-- first so that the corresponding 'Prelude.Enum' instance will give+-- 'Prelude.fromEnum' 'False' the value zero, and+-- 'Prelude.fromEnum' 'True' the value 1.+-- The actual definition is in the ghc-prim package.++-- XXX These don't work:+-- deriving instance Eq Bool+-- deriving instance Ord Bool+-- <wired into compiler>:+--     Illegal binding of built-in syntax: con2tag_Bool#++instance Eq Bool where+    True  == True  = True+    False == False = True+    _     == _     = False++instance Ord Bool where+    compare False True  = LT+    compare True  False = GT+    compare _     _     = EQ++-- Read is in GHC.Read, Show in GHC.Show++-- |'otherwise' is defined as the value 'True'.  It helps to make+-- guards more readable.  eg.+--+-- >  f x | x < 0     = ...+-- >      | otherwise = ...+otherwise               :: Bool+otherwise               =  True+\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Ordering@}+%*                                                      *+%*********************************************************++\begin{code}+-- | Represents an ordering relationship between two values: less+-- than, equal to, or greater than.  An 'Ordering' is returned by+-- 'compare'.+-- XXX These don't work:+-- deriving instance Eq Ordering+-- deriving instance Ord Ordering+-- Illegal binding of built-in syntax: con2tag_Ordering#+instance Eq Ordering where+    EQ == EQ = True+    LT == LT = True+    GT == GT = True+    _  == _  = False+        -- Read in GHC.Read, Show in GHC.Show++instance Ord Ordering where+    LT <= _  = True+    _  <= LT = False+    EQ <= _  = True+    _  <= EQ = False+    GT <= GT = True+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Char@ and @String@}+%*                                                      *+%*********************************************************++\begin{code}+-- | A 'String' is a list of characters.  String constants in Haskell are values+-- of type 'String'.+--+type String = [Char]++{-| The character type 'Char' is an enumeration whose values represent+Unicode (or equivalently ISO\/IEC 10646) characters+(see <http://www.unicode.org/> for details).+This set extends the ISO 8859-1 (Latin-1) character set+(the first 256 charachers), which is itself an extension of the ASCII+character set (the first 128 characters).+A character literal in Haskell has type 'Char'.++To convert a 'Char' to or from the corresponding 'Int' value defined+by Unicode, use 'Prelude.toEnum' and 'Prelude.fromEnum' from the+'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr').+-}++-- We don't use deriving for Eq and Ord, because for Ord the derived+-- instance defines only compare, which takes two primops.  Then+-- '>' uses compare, and therefore takes two primops instead of one.++instance Eq Char where+    (C# c1) == (C# c2) = c1 `eqChar#` c2+    (C# c1) /= (C# c2) = c1 `neChar#` c2++instance Ord Char where+    (C# c1) >  (C# c2) = c1 `gtChar#` c2+    (C# c1) >= (C# c2) = c1 `geChar#` c2+    (C# c1) <= (C# c2) = c1 `leChar#` c2+    (C# c1) <  (C# c2) = c1 `ltChar#` c2++{-# RULES+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False+  #-}++-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.+chr :: Int -> Char+chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)+            | otherwise                                  = error "Prelude.chr: bad argument"++unsafeChr :: Int -> Char+unsafeChr (I# i#) = C# (chr# i#)++-- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.+ord :: Char -> Int+ord (C# c#) = I# (ord# c#)+\end{code}++String equality is used when desugaring pattern-matches against strings.++\begin{code}+eqString :: String -> String -> Bool+eqString []       []       = True+eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2+eqString _        _        = False++{-# RULES "eqString" (==) = eqString #-}+-- eqString also has a BuiltInRule in PrelRules.lhs:+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Int@}+%*                                                      *+%*********************************************************++\begin{code}+zeroInt, oneInt, twoInt, maxInt, minInt :: Int+zeroInt = I# 0#+oneInt  = I# 1#+twoInt  = I# 2#++{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}+#if WORD_SIZE == 4+minInt  = I# (-0x80000000#)+maxInt  = I# 0x7FFFFFFF#+#else+minInt  = I# (-0x8000000000000000#)+maxInt  = I# 0x7FFFFFFFFFFFFFFF#+#endif++instance Eq Int where+    (==) = eqInt+    (/=) = neInt++instance Ord Int where+    compare = compareInt+    (<)     = ltInt+    (<=)    = leInt+    (>=)    = geInt+    (>)     = gtInt++compareInt :: Int -> Int -> Ordering+(I# x#) `compareInt` (I# y#) = compareInt# x# y#++compareInt# :: Int# -> Int# -> Ordering+compareInt# x# y#+    | x# <#  y# = LT+    | x# ==# y# = EQ+    | otherwise = GT+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The function type}+%*                                                      *+%*********************************************************++\begin{code}+-- | Identity function.+id                      :: a -> a+id x                    =  x++-- | The call '(lazy e)' means the same as 'e', but 'lazy' has a +-- magical strictness property: it is lazy in its first argument, +-- even though its semantics is strict.+lazy :: a -> a+lazy x = x+-- Implementation note: its strictness and unfolding are over-ridden+-- by the definition in MkId.lhs; in both cases to nothing at all.+-- That way, 'lazy' does not get inlined, and the strictness analyser+-- sees it as lazy.  Then the worker/wrapper phase inlines it.+-- Result: happiness+++-- | The call '(inline f)' reduces to 'f', but 'inline' has a BuiltInRule+-- that tries to inline 'f' (if it has an unfolding) unconditionally+-- The 'NOINLINE' pragma arranges that inline only gets inlined (and+-- hence eliminated) late in compilation, after the rule has had+-- a god chance to fire.+inline :: a -> a+{-# NOINLINE[0] inline #-}+inline x = x++-- Assertion function.  This simply ignores its boolean argument.+-- The compiler may rewrite it to @('assertError' line)@.++-- | If the first argument evaluates to 'True', then the result is the+-- second argument.  Otherwise an 'AssertionFailed' exception is raised,+-- containing a 'String' with the source file and line number of the+-- call to 'assert'.+--+-- Assertions can normally be turned on or off with a compiler flag+-- (for GHC, assertions are normally on unless optimisation is turned on +-- with @-O@ or the @-fignore-asserts@+-- option is given).  When assertions are turned off, the first+-- argument to 'assert' is ignored, and the second argument is+-- returned as the result.++--      SLPJ: in 5.04 etc 'assert' is in GHC.Prim,+--      but from Template Haskell onwards it's simply+--      defined here in Base.lhs+assert :: Bool -> a -> a+assert _pred r = r++breakpoint :: a -> a+breakpoint r = r++breakpointCond :: Bool -> a -> a+breakpointCond _ r = r++data Opaque = forall a. O a++-- | Constant function.+const                   :: a -> b -> a+const x _               =  x++-- | Function composition.+{-# INLINE (.) #-}+(.)       :: (b -> c) -> (a -> b) -> a -> c+(.) f g x = f (g x)++-- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@.+flip                    :: (a -> b -> c) -> b -> a -> c+flip f x y              =  f y x++-- | Application operator.  This operator is redundant, since ordinary+-- application @(f x)@ means the same as @(f '$' x)@. However, '$' has+-- low, right-associative binding precedence, so it sometimes allows+-- parentheses to be omitted; for example:+--+-- >     f $ g $ h x  =  f (g (h x))+--+-- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@,+-- or @'Data.List.zipWith' ('$') fs xs@.+{-# INLINE ($) #-}+($)                     :: (a -> b) -> a -> b+f $ x                   =  f x++-- | @'until' p f@ yields the result of applying @f@ until @p@ holds.+until                   :: (a -> Bool) -> (a -> a) -> a -> a+until p f x | p x       =  x+            | otherwise =  until p f (f 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.+asTypeOf                :: a -> a -> a+asTypeOf                =  const+\end{code}++%*********************************************************+%*                                                      *+\subsection{@getTag@}+%*                                                      *+%*********************************************************++Returns the 'tag' of a constructor application; this function is used+by the deriving code for Eq, Ord and Enum.++The primitive dataToTag# requires an evaluated constructor application+as its argument, so we provide getTag as a wrapper that performs the+evaluation before calling dataToTag#.  We could have dataToTag#+evaluate its argument, but we prefer to do it this way because (a)+dataToTag# can be an inline primop if it doesn't need to do any+evaluation, and (b) we want to expose the evaluation to the+simplifier, because it might be possible to eliminate the evaluation+in the case when the argument is already known to be evaluated.++\begin{code}+{-# INLINE getTag #-}+getTag :: a -> Int#+getTag x = x `seq` dataToTag# x+\end{code}++%*********************************************************+%*                                                      *+\subsection{Numeric primops}+%*                                                      *+%*********************************************************++\begin{code}+divInt# :: Int# -> Int# -> Int#+x# `divInt#` y#+        -- Be careful NOT to overflow if we do any additional arithmetic+        -- on the arguments...  the following  previous version of this+        -- code has problems with overflow:+--    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#+--    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#+    | (x# ># 0#) && (y# <# 0#) = ((x# -# 1#) `quotInt#` y#) -# 1#+    | (x# <# 0#) && (y# ># 0#) = ((x# +# 1#) `quotInt#` y#) -# 1#+    | otherwise                = x# `quotInt#` y#++modInt# :: Int# -> Int# -> Int#+x# `modInt#` y#+    | (x# ># 0#) && (y# <# 0#) ||+      (x# <# 0#) && (y# ># 0#)    = if r# /=# 0# then r# +# y# else 0#+    | otherwise                   = r#+    where+    r# = x# `remInt#` y#+\end{code}++Definitions of the boxed PrimOps; these will be+used in the case of partial applications, etc.++\begin{code}+{-# INLINE eqInt #-}+{-# INLINE neInt #-}+{-# INLINE gtInt #-}+{-# INLINE geInt #-}+{-# INLINE ltInt #-}+{-# INLINE leInt #-}+{-# INLINE plusInt #-}+{-# INLINE minusInt #-}+{-# INLINE timesInt #-}+{-# INLINE quotInt #-}+{-# INLINE remInt #-}+{-# INLINE negateInt #-}++plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int+(I# x) `plusInt`  (I# y) = I# (x +# y)+(I# x) `minusInt` (I# y) = I# (x -# y)+(I# x) `timesInt` (I# y) = I# (x *# y)+(I# x) `quotInt`  (I# y) = I# (x `quotInt#` y)+(I# x) `remInt`   (I# y) = I# (x `remInt#`  y)+(I# x) `divInt`   (I# y) = I# (x `divInt#`  y)+(I# x) `modInt`   (I# y) = I# (x `modInt#`  y)++{-# RULES+"x# +# 0#" forall x#. x# +# 0# = x#+"0# +# x#" forall x#. 0# +# x# = x#+"x# -# 0#" forall x#. x# -# 0# = x#+"x# -# x#" forall x#. x# -# x# = 0#+"x# *# 0#" forall x#. x# *# 0# = 0#+"0# *# x#" forall x#. 0# *# x# = 0#+"x# *# 1#" forall x#. x# *# 1# = x#+"1# *# x#" forall x#. 1# *# x# = x#+  #-}++gcdInt (I# a) (I# b) = g a b+   where g 0# 0# = error "GHC.Base.gcdInt: gcd 0 0 is undefined"+         g 0# _  = I# absB+         g _  0# = I# absA+         g _  _  = I# (gcdInt# absA absB)++         absInt x = if x <# 0# then negateInt# x else x++         absA     = absInt a+         absB     = absInt b++negateInt :: Int -> Int+negateInt (I# x) = I# (negateInt# x)++gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool+(I# x) `gtInt` (I# y) = x >#  y+(I# x) `geInt` (I# y) = x >=# y+(I# x) `eqInt` (I# y) = x ==# y+(I# x) `neInt` (I# y) = x /=# y+(I# x) `ltInt` (I# y) = x <#  y+(I# x) `leInt` (I# y) = x <=# y++{-# RULES+"x# ># x#"  forall x#. x# >#  x# = False+"x# >=# x#" forall x#. x# >=# x# = True+"x# ==# x#" forall x#. x# ==# x# = True+"x# /=# x#" forall x#. x# /=# x# = False+"x# <# x#"  forall x#. x# <#  x# = False+"x# <=# x#" forall x#. x# <=# x# = True+  #-}++{-# RULES+"plusFloat x 0.0"   forall x#. plusFloat#  x#   0.0# = x#+"plusFloat 0.0 x"   forall x#. plusFloat#  0.0# x#   = x#+"minusFloat x 0.0"  forall x#. minusFloat# x#   0.0# = x#+"minusFloat x x"    forall x#. minusFloat# x#   x#   = 0.0#+"timesFloat x 0.0"  forall x#. timesFloat# x#   0.0# = 0.0#+"timesFloat0.0 x"   forall x#. timesFloat# 0.0# x#   = 0.0#+"timesFloat x 1.0"  forall x#. timesFloat# x#   1.0# = x#+"timesFloat 1.0 x"  forall x#. timesFloat# 1.0# x#   = x#+"divideFloat x 1.0" forall x#. divideFloat# x#  1.0# = x#+  #-}++{-# RULES+"plusDouble x 0.0"   forall x#. (+##) x#    0.0## = x#+"plusDouble 0.0 x"   forall x#. (+##) 0.0## x#    = x#+"minusDouble x 0.0"  forall x#. (-##) x#    0.0## = x#+"timesDouble x 1.0"  forall x#. (*##) x#    1.0## = x#+"timesDouble 1.0 x"  forall x#. (*##) 1.0## x#    = x#+"divideDouble x 1.0" forall x#. (/##) x#    1.0## = x#+  #-}++{-+We'd like to have more rules, but for example:++This gives wrong answer (0) for NaN - NaN (should be NaN):+    "minusDouble x x"    forall x#. (-##) x#    x#    = 0.0##++This gives wrong answer (0) for 0 * NaN (should be NaN):+    "timesDouble 0.0 x"  forall x#. (*##) 0.0## x#    = 0.0##++This gives wrong answer (0) for NaN * 0 (should be NaN):+    "timesDouble x 0.0"  forall x#. (*##) x#    0.0## = 0.0##++These are tested by num014.+-}++-- Wrappers for the shift operations.  The uncheckedShift# family are+-- undefined when the amount being shifted by is greater than the size+-- in bits of Int#, so these wrappers perform a check and return+-- either zero or -1 appropriately.+--+-- Note that these wrappers still produce undefined results when the+-- second argument (the shift amount) is negative.++-- | Shift the argument left by the specified number of bits+-- (which must be non-negative).+shiftL# :: Word# -> Int# -> Word#+a `shiftL#` b   | b >=# WORD_SIZE_IN_BITS_ = int2Word# 0#+                | otherwise                = a `uncheckedShiftL#` b++-- | Shift the argument right by the specified number of bits+-- (which must be non-negative).+shiftRL# :: Word# -> Int# -> Word#+a `shiftRL#` b  | b >=# WORD_SIZE_IN_BITS_ = int2Word# 0#+                | otherwise                = a `uncheckedShiftRL#` b++-- | Shift the argument left by the specified number of bits+-- (which must be non-negative).+iShiftL# :: Int# -> Int# -> Int#+a `iShiftL#` b  | b >=# WORD_SIZE_IN_BITS_ = 0#+                | otherwise                = a `uncheckedIShiftL#` b++-- | Shift the argument right (signed) by the specified number of bits+-- (which must be non-negative).+iShiftRA# :: Int# -> Int# -> Int#+a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS_ = if a <# 0# then (-1#) else 0#+                | otherwise                = a `uncheckedIShiftRA#` b++-- | Shift the argument right (unsigned) by the specified number of bits+-- (which must be non-negative).+iShiftRL# :: Int# -> Int# -> Int#+a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS_ = 0#+                | otherwise                = a `uncheckedIShiftRL#` b++#if WORD_SIZE == 4+{-# RULES+"narrow32Int#"  forall x#. narrow32Int#   x# = x#+"narrow32Word#" forall x#. narrow32Word#   x# = x#+   #-}+#endif++{-# RULES+"int2Word2Int"  forall x#. int2Word# (word2Int# x#) = x#+"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#+  #-}+\end{code}+++%********************************************************+%*                                                      *+\subsection{Unpacking C strings}+%*                                                      *+%********************************************************++This code is needed for virtually all programs, since it's used for+unpacking the strings of error messages.++\begin{code}+unpackCString# :: Addr# -> [Char]+{-# NOINLINE [1] unpackCString# #-}+unpackCString# addr +  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'# = []+      | otherwise          = C# ch : unpack (nh +# 1#)+      where+        ch = indexCharOffAddr# addr nh++unpackAppendCString# :: Addr# -> [Char] -> [Char]+unpackAppendCString# addr rest+  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'# = rest+      | otherwise          = C# ch : unpack (nh +# 1#)+      where+        ch = indexCharOffAddr# addr nh++unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a +{-# NOINLINE [0] unpackFoldrCString# #-}+-- Don't inline till right at the end;+-- usually the unpack-list rule turns it into unpackCStringList+-- It also has a BuiltInRule in PrelRules.lhs:+--      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)+--        =  unpackFoldrCString# "foobaz" c n+unpackFoldrCString# addr f z +  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'# = z+      | otherwise          = C# ch `f` unpack (nh +# 1#)+      where+        ch = indexCharOffAddr# addr nh++unpackCStringUtf8# :: Addr# -> [Char]+unpackCStringUtf8# addr +  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'#   = []+      | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)+      | ch `leChar#` '\xDF'# =+          C# (chr# (((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :+          unpack (nh +# 2#)+      | ch `leChar#` '\xEF'# =+          C# (chr# (((ord# ch                                  -# 0xE0#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :+          unpack (nh +# 3#)+      | otherwise            =+          C# (chr# (((ord# ch                                  -# 0xF0#) `uncheckedIShiftL#` 18#) +#+                    ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :+          unpack (nh +# 4#)+      where+        ch = indexCharOffAddr# addr nh++unpackNBytes# :: Addr# -> Int# -> [Char]+unpackNBytes# _addr 0#   = []+unpackNBytes#  addr len# = unpack [] (len# -# 1#)+    where+     unpack acc i#+      | i# <# 0#  = acc+      | otherwise = +         case indexCharOffAddr# addr i# of+            ch -> unpack (C# ch : acc) (i# -# 1#)++{-# RULES+"unpack"       [~1] forall a   . unpackCString# a                  = build (unpackFoldrCString# a)+"unpack-list"  [1]  forall a   . unpackFoldrCString# a (:) [] = unpackCString# a+"unpack-append"     forall a n . unpackFoldrCString# a (:) n  = unpackAppendCString# a n++-- There's a built-in rule (in PrelRules.lhs) for+--      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n++  #-}+\end{code}++#ifdef __HADDOCK__+\begin{code}+-- | A special argument for the 'Control.Monad.ST.ST' type constructor,+-- indexing a state embedded in the 'Prelude.IO' monad by+-- 'Control.Monad.ST.stToIO'.+data RealWorld+\end{code}+#endif
+ lib/base/src/GHC/Classes.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Classes+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic classes.+--+-----------------------------------------------------------------------------++module GHC.Classes where++import GHC.Bool+import GHC.Ordering++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||++default ()              -- Double isn't available yet++-- | The 'Eq' class defines equality ('==') and inequality ('/=').+-- All the basic datatypes exported by the "Prelude" are instances of 'Eq',+-- and 'Eq' may be derived for any datatype whose constituents are also+-- instances of 'Eq'.+--+-- Minimal complete definition: either '==' or '/='.+--+class  Eq a  where+    (==), (/=)           :: a -> a -> Bool++    x /= y               = not (x == y)+    x == y               = not (x /= y)++-- | The 'Ord' class is used for totally ordered datatypes.+--+-- Instances of 'Ord' can be derived for any user-defined+-- datatype whose constituent types are in 'Ord'.  The declared order+-- of the constructors in the data declaration determines the ordering+-- in derived 'Ord' instances.  The 'Ordering' datatype allows a single+-- comparison to determine the precise ordering of two objects.+--+-- Minimal complete definition: either 'compare' or '<='.+-- Using 'compare' can be more efficient for complex types.+--+class  (Eq a) => Ord a  where+    compare              :: a -> a -> Ordering+    (<), (<=), (>), (>=) :: a -> a -> Bool+    max, min             :: a -> a -> a++    compare x y = if x == y then EQ+                  -- NB: must be '<=' not '<' to validate the+                  -- above claim about the minimal things that+                  -- can be defined for an instance of Ord:+                  else if x <= y then LT+                  else GT++    x <  y = case compare x y of { LT -> True;  _ -> False }+    x <= y = case compare x y of { GT -> False; _ -> True }+    x >  y = case compare x y of { GT -> True;  _ -> False }+    x >= y = case compare x y of { LT -> False; _ -> True }++        -- These two default methods use '<=' rather than 'compare'+        -- because the latter is often more expensive+    max x y = if x <= y then y else x+    min x y = if x <= y then x else y++-- OK, so they're technically not part of a class...:++-- Boolean functions++-- | Boolean \"and\"+(&&)                    :: Bool -> Bool -> Bool+True  && x              =  x+False && _              =  False++-- | Boolean \"or\"+(||)                    :: Bool -> Bool -> Bool+True  || _              =  True+False || x              =  x++-- | Boolean \"not\"+not                     :: Bool -> Bool+not True                =  False+not False               =  True+
+ lib/base/src/GHC/Conc.lhs view
@@ -0,0 +1,1388 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Conc+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic concurrency stuff.+-- +-----------------------------------------------------------------------------++-- No: #hide, because bits of this module are exposed by the stm package.+-- However, we don't want this module to be the home location for the+-- bits it exports, we'd rather have Control.Concurrent and the other+-- higher level modules be the home.  Hence:++#include "Typeable.h"++-- #not-home+module GHC.Conc+        ( ThreadId(..)++        -- * Forking and suchlike+        , forkIO        -- :: IO a -> IO ThreadId+        , forkOnIO      -- :: Int -> IO a -> IO ThreadId+        , numCapabilities -- :: Int+        , childHandler  -- :: Exception -> IO ()+        , myThreadId    -- :: IO ThreadId+        , killThread    -- :: ThreadId -> IO ()+        , throwTo       -- :: ThreadId -> Exception -> IO ()+        , par           -- :: a -> b -> b+        , pseq          -- :: a -> b -> b+        , yield         -- :: IO ()+        , labelThread   -- :: ThreadId -> String -> IO ()++        , ThreadStatus(..), BlockReason(..)+        , threadStatus  -- :: ThreadId -> IO ThreadStatus++        -- * Waiting+        , threadDelay           -- :: Int -> IO ()+        , registerDelay         -- :: Int -> IO (TVar Bool)+        , threadWaitRead        -- :: Int -> IO ()+        , threadWaitWrite       -- :: Int -> IO ()++        -- * MVars+        , MVar(..)+        , newMVar       -- :: a -> IO (MVar a)+        , newEmptyMVar  -- :: IO (MVar a)+        , takeMVar      -- :: MVar a -> IO a+        , putMVar       -- :: MVar a -> a -> IO ()+        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)+        , tryPutMVar    -- :: MVar a -> a -> IO Bool+        , isEmptyMVar   -- :: MVar a -> IO Bool+        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()++        -- * TVars+        , STM(..)+        , atomically    -- :: STM a -> IO a+        , retry         -- :: STM a+        , orElse        -- :: STM a -> STM a -> STM a+        , catchSTM      -- :: STM a -> (Exception -> STM a) -> STM a+        , alwaysSucceeds -- :: STM a -> STM ()+        , always        -- :: STM Bool -> STM ()+        , TVar(..)+        , newTVar       -- :: a -> STM (TVar a)+        , newTVarIO     -- :: a -> STM (TVar a)+        , readTVar      -- :: TVar a -> STM a+        , writeTVar     -- :: a -> TVar a -> STM ()+        , unsafeIOToSTM -- :: IO a -> STM a++        -- * Miscellaneous+#ifdef mingw32_HOST_OS+        , asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)+        , asyncWrite    -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)+        , asyncDoProc   -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int++        , asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)+        , asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)+#endif++#ifndef mingw32_HOST_OS+        , Signal, HandlerFun, setHandler, runHandlers+#endif++        , ensureIOManagerIsRunning+#ifndef mingw32_HOST_OS+        , syncIOManager+#endif++#ifdef mingw32_HOST_OS+        , ConsoleEvent(..)+        , win32ConsoleHandler+        , toWin32ConsoleEvent+#endif+        , setUncaughtExceptionHandler      -- :: (Exception -> IO ()) -> IO ()+        , getUncaughtExceptionHandler      -- :: IO (Exception -> IO ())++        , reportError, reportStackOverflow+        ) where++import System.Posix.Types+#ifndef mingw32_HOST_OS+import System.Posix.Internals+#endif+import Foreign+import Foreign.C++#ifndef mingw32_HOST_OS+import Data.Dynamic+import Control.Monad+#endif+import Data.Maybe++import GHC.Base+import {-# SOURCE #-} GHC.Handle+import GHC.IOBase+import GHC.Num          ( Num(..) )+import GHC.Real         ( fromIntegral )+#ifndef mingw32_HOST_OS+import GHC.Arr          ( inRange )+#endif+#ifdef mingw32_HOST_OS+import GHC.Real         ( div )+import GHC.Ptr          ( plusPtr, FunPtr(..) )+#endif+#ifdef mingw32_HOST_OS+import GHC.Read         ( Read )+import GHC.Enum         ( Enum )+#endif+import GHC.Exception    ( SomeException(..), ErrorCall(..), throw )+import GHC.Pack         ( packCString# )+import GHC.Ptr          ( Ptr(..) )+import GHC.STRef+import GHC.Show         ( Show(..), showString )+import Data.Typeable+import GHC.Err++infixr 0 `par`, `pseq`+\end{code}++%************************************************************************+%*                                                                      *+\subsection{@ThreadId@, @par@, and @fork@}+%*                                                                      *+%************************************************************************++\begin{code}+data ThreadId = ThreadId ThreadId# deriving( Typeable )+-- ToDo: data ThreadId = ThreadId (Weak ThreadId#)+-- But since ThreadId# is unlifted, the Weak type must use open+-- type variables.+{- ^+A 'ThreadId' is an abstract type representing a handle to a thread.+'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where+the 'Ord' instance implements an arbitrary total ordering over+'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued+'ThreadId' to string form; showing a 'ThreadId' value is occasionally+useful when debugging or diagnosing the behaviour of a concurrent+program.++/Note/: in GHC, if you have a 'ThreadId', you essentially have+a pointer to the thread itself.  This means the thread itself can\'t be+garbage collected until you drop the 'ThreadId'.+This misfeature will hopefully be corrected at a later date.++/Note/: Hugs does not provide any operations on other threads;+it defines 'ThreadId' as a synonym for ().+-}++instance Show ThreadId where+   showsPrec d t = +        showString "ThreadId " . +        showsPrec d (getThreadId (id2TSO t))++foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt++id2TSO :: ThreadId -> ThreadId#+id2TSO (ThreadId t) = t++foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt+-- Returns -1, 0, 1++cmpThread :: ThreadId -> ThreadId -> Ordering+cmpThread t1 t2 = +   case cmp_thread (id2TSO t1) (id2TSO t2) of+      -1 -> LT+      0  -> EQ+      _  -> GT -- must be 1++instance Eq ThreadId where+   t1 == t2 = +      case t1 `cmpThread` t2 of+         EQ -> True+         _  -> False++instance Ord ThreadId where+   compare = cmpThread++{- |+Sparks off a new thread to run the 'IO' computation passed as the+first argument, and returns the 'ThreadId' of the newly created+thread.++The new thread will be a lightweight thread; if you want to use a foreign+library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.++GHC note: the new thread inherits the /blocked/ state of the parent +(see 'Control.Exception.block').++The newly created thread has an exception handler that discards the+exceptions 'BlockedOnDeadMVar', 'BlockedIndefinitely', and+'ThreadKilled', and passes all other exceptions to the uncaught+exception handler (see 'setUncaughtExceptionHandler').+-}+forkIO :: IO () -> IO ThreadId+forkIO action = IO $ \ s -> +   case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)+ where+  action_plus = catchException action childHandler++{- |+Like 'forkIO', but lets you specify on which CPU the thread is+created.  Unlike a `forkIO` thread, a thread created by `forkOnIO`+will stay on the same CPU for its entire lifetime (`forkIO` threads+can migrate between CPUs according to the scheduling policy).+`forkOnIO` is useful for overriding the scheduling policy when you+know in advance how best to distribute the threads.++The `Int` argument specifies the CPU number; it is interpreted modulo+'numCapabilities' (note that it actually specifies a capability number+rather than a CPU number, but to a first approximation the two are+equivalent).+-}+forkOnIO :: Int -> IO () -> IO ThreadId+forkOnIO (I# cpu) action = IO $ \ s -> +   case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)+ where+  action_plus = catchException action childHandler++-- | the value passed to the @+RTS -N@ flag.  This is the number of+-- Haskell threads that can run truly simultaneously at any given+-- time, and is typically set to the number of physical CPU cores on+-- the machine.+numCapabilities :: Int+numCapabilities = unsafePerformIO $  do +                    n <- peek n_capabilities+                    return (fromIntegral n)++foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt++childHandler :: SomeException -> IO ()+childHandler err = catchException (real_handler err) childHandler++real_handler :: SomeException -> IO ()+real_handler se@(SomeException ex) =+  -- ignore thread GC and killThread exceptions:+  case cast ex of+  Just BlockedOnDeadMVar                -> return ()+  _ -> case cast ex of+       Just BlockedIndefinitely         -> return ()+       _ -> case cast ex of+            Just ThreadKilled           -> return ()+            _ -> case cast ex of+                 -- report all others:+                 Just StackOverflow     -> reportStackOverflow+                 _                      -> reportError se++{- | 'killThread' terminates the given thread (GHC only).+Any work already done by the thread isn\'t+lost: the computation is suspended until required by another thread.+The memory used by the thread will be garbage collected if it isn\'t+referenced from anywhere.  The 'killThread' function is defined in+terms of 'throwTo':++> killThread tid = throwTo tid ThreadKilled++Killthread is a no-op if the target thread has already completed.+-}+killThread :: ThreadId -> IO ()+killThread tid = throwTo tid ThreadKilled++{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).++'throwTo' does not return until the exception has been raised in the+target thread. +The calling thread can thus be certain that the target+thread has received the exception.  This is a useful property to know+when dealing with race conditions: eg. if there are two threads that+can kill each other, it is guaranteed that only one of the threads+will get to kill the other.++If the target thread is currently making a foreign call, then the+exception will not be raised (and hence 'throwTo' will not return)+until the call has completed.  This is the case regardless of whether+the call is inside a 'block' or not.++Important note: the behaviour of 'throwTo' differs from that described in+the paper \"Asynchronous exceptions in Haskell\"+(<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).+In the paper, 'throwTo' is non-blocking; but the library implementation adopts+a more synchronous design in which 'throwTo' does not return until the exception+is received by the target thread.  The trade-off is discussed in Section 9 of the paper.+Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of+the paper).++There is currently no guarantee that the exception delivered by 'throwTo' will be+delivered at the first possible opportunity.  In particular, a thread may +unblock and then re-block exceptions (using 'unblock' and 'block') without receiving+a pending 'throwTo'.  This is arguably undesirable behaviour.++ -}+throwTo :: Exception e => ThreadId -> e -> IO ()+throwTo (ThreadId tid) ex = IO $ \ s ->+   case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)++-- | Returns the 'ThreadId' of the calling thread (GHC only).+myThreadId :: IO ThreadId+myThreadId = IO $ \s ->+   case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)+++-- |The 'yield' action allows (forces, in a co-operative multitasking+-- implementation) a context-switch to any other currently runnable+-- threads (if any), and is occasionally useful when implementing+-- concurrency abstractions.+yield :: IO ()+yield = IO $ \s -> +   case (yield# s) of s1 -> (# s1, () #)++{- | 'labelThread' stores a string as identifier for this thread if+you built a RTS with debugging support. This identifier will be used in+the debugging output to make distinction of different threads easier+(otherwise you only have the thread state object\'s address in the heap).++Other applications like the graphical Concurrent Haskell Debugger+(<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload+'labelThread' for their purposes as well.+-}++labelThread :: ThreadId -> String -> IO ()+labelThread (ThreadId t) str = IO $ \ s ->+   let ps  = packCString# str+       adr = byteArrayContents# ps in+     case (labelThread# t adr s) of s1 -> (# s1, () #)++--      Nota Bene: 'pseq' used to be 'seq'+--                 but 'seq' is now defined in PrelGHC+--+-- "pseq" is defined a bit weirdly (see below)+--+-- The reason for the strange "lazy" call is that+-- it fools the compiler into thinking that pseq  and par are non-strict in+-- their second argument (even if it inlines pseq at the call site).+-- If it thinks pseq is strict in "y", then it often evaluates+-- "y" before "x", which is totally wrong.  ++{-# INLINE pseq  #-}+pseq :: a -> b -> b+pseq  x y = x `seq` lazy y++{-# INLINE par  #-}+par :: a -> b -> b+par  x y = case (par# x) of { _ -> lazy y }+++data BlockReason+  = BlockedOnMVar+        -- ^blocked on on 'MVar'+  | BlockedOnBlackHole+        -- ^blocked on a computation in progress by another thread+  | BlockedOnException+        -- ^blocked in 'throwTo'+  | BlockedOnSTM+        -- ^blocked in 'retry' in an STM transaction+  | BlockedOnForeignCall+        -- ^currently in a foreign call+  | BlockedOnOther+        -- ^blocked on some other resource.  Without @-threaded@,+        -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@+        -- they show up as 'BlockedOnMVar'.+  deriving (Eq,Ord,Show)++-- | The current status of a thread+data ThreadStatus+  = ThreadRunning+        -- ^the thread is currently runnable or running+  | ThreadFinished+        -- ^the thread has finished+  | ThreadBlocked  BlockReason+        -- ^the thread is blocked on some resource+  | ThreadDied+        -- ^the thread received an uncaught exception+  deriving (Eq,Ord,Show)++threadStatus :: ThreadId -> IO ThreadStatus+threadStatus (ThreadId t) = IO $ \s ->+   case threadStatus# t s of+     (# s', stat #) -> (# s', mk_stat (I# stat) #)+   where+        -- NB. keep these in sync with includes/Constants.h+     mk_stat 0  = ThreadRunning+     mk_stat 1  = ThreadBlocked BlockedOnMVar+     mk_stat 2  = ThreadBlocked BlockedOnBlackHole+     mk_stat 3  = ThreadBlocked BlockedOnException+     mk_stat 7  = ThreadBlocked BlockedOnSTM+     mk_stat 11 = ThreadBlocked BlockedOnForeignCall+     mk_stat 12 = ThreadBlocked BlockedOnForeignCall+     mk_stat 16 = ThreadFinished+     mk_stat 17 = ThreadDied+     mk_stat _  = ThreadBlocked BlockedOnOther+\end{code}+++%************************************************************************+%*                                                                      *+\subsection[stm]{Transactional heap operations}+%*                                                                      *+%************************************************************************++TVars are shared memory locations which support atomic memory+transactions.++\begin{code}+-- |A monad supporting atomic memory transactions.+newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))++unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))+unSTM (STM a) = a++INSTANCE_TYPEABLE1(STM,stmTc,"STM")++instance  Functor STM where+   fmap f x = x >>= (return . f)++instance  Monad STM  where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    m >> k      = thenSTM m k+    return x    = returnSTM x+    m >>= k     = bindSTM m k++bindSTM :: STM a -> (a -> STM b) -> STM b+bindSTM (STM m) k = STM ( \s ->+  case m s of +    (# new_s, a #) -> unSTM (k a) new_s+  )++thenSTM :: STM a -> STM b -> STM b+thenSTM (STM m) k = STM ( \s ->+  case m s of +    (# new_s, _ #) -> unSTM k new_s+  )++returnSTM :: a -> STM a+returnSTM x = STM (\s -> (# s, x #))++-- | Unsafely performs IO in the STM monad.  Beware: this is a highly+-- dangerous thing to do.  +--+--   * The STM implementation will often run transactions multiple+--     times, so you need to be prepared for this if your IO has any+--     side effects.+--+--   * The STM implementation will abort transactions that are known to+--     be invalid and need to be restarted.  This may happen in the middle+--     of `unsafeIOToSTM`, so make sure you don't acquire any resources+--     that need releasing (exception handlers are ignored when aborting+--     the transaction).  That includes doing any IO using Handles, for+--     example.  Getting this wrong will probably lead to random deadlocks.+--+--   * The transaction may have seen an inconsistent view of memory when+--     the IO runs.  Invariants that you expect to be true throughout+--     your program may not be true inside a transaction, due to the+--     way transactions are implemented.  Normally this wouldn't be visible+--     to the programmer, but using `unsafeIOToSTM` can expose it.+--+unsafeIOToSTM :: IO a -> STM a+unsafeIOToSTM (IO m) = STM m++-- |Perform a series of STM actions atomically.+--+-- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. +-- Any attempt to do so will result in a runtime error.  (Reason: allowing+-- this would effectively allow a transaction inside a transaction, depending+-- on exactly when the thunk is evaluated.)+--+-- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',+-- and which allows top-level TVars to be allocated.++atomically :: STM a -> IO a+atomically (STM m) = IO (\s -> (atomically# m) s )++-- |Retry execution of the current memory transaction because it has seen+-- values in TVars which mean that it should not continue (e.g. the TVars+-- represent a shared buffer that is now empty).  The implementation may+-- block the thread until one of the TVars that it has read from has been+-- udpated. (GHC only)+retry :: STM a+retry = STM $ \s# -> retry# s#++-- |Compose two alternative STM actions (GHC only).  If the first action+-- completes without retrying then it forms the result of the orElse.+-- Otherwise, if the first action retries, then the second action is+-- tried in its place.  If both actions retry then the orElse as a+-- whole retries.+orElse :: STM a -> STM a -> STM a+orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s++-- |Exception handling within STM actions.+catchSTM :: STM a -> (SomeException -> STM a) -> STM a+catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s++-- | Low-level primitive on which always and alwaysSucceeds are built.+-- checkInv differs form these in that (i) the invariant is not +-- checked when checkInv is called, only at the end of this and+-- subsequent transcations, (ii) the invariant failure is indicated+-- by raising an exception.+checkInv :: STM a -> STM ()+checkInv (STM m) = STM (\s -> (check# m) s)++-- | alwaysSucceeds adds a new invariant that must be true when passed+-- to alwaysSucceeds, at the end of the current transaction, and at+-- the end of every subsequent transaction.  If it fails at any+-- of those points then the transaction violating it is aborted+-- and the exception raised by the invariant is propagated.+alwaysSucceeds :: STM a -> STM ()+alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () ) +                      checkInv i++-- | always is a variant of alwaysSucceeds in which the invariant is+-- expressed as an STM Bool action that must return True.  Returning+-- False or raising an exception are both treated as invariant failures.+always :: STM Bool -> STM ()+always i = alwaysSucceeds ( do v <- i+                               if (v) then return () else ( error "Transacional invariant violation" ) )++-- |Shared memory locations that support atomic memory transactions.+data TVar a = TVar (TVar# RealWorld a)++INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")++instance Eq (TVar a) where+        (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#++-- |Create a new TVar holding a value supplied+newTVar :: a -> STM (TVar a)+newTVar val = STM $ \s1# ->+    case newTVar# val s1# of+         (# s2#, tvar# #) -> (# s2#, TVar tvar# #)++-- |@IO@ version of 'newTVar'.  This is useful for creating top-level+-- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTVarIO :: a -> IO (TVar a)+newTVarIO val = IO $ \s1# ->+    case newTVar# val s1# of+         (# s2#, tvar# #) -> (# s2#, TVar tvar# #)++-- |Return the current value stored in a TVar+readTVar :: TVar a -> STM a+readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#++-- |Write the supplied value into a TVar+writeTVar :: TVar a -> a -> STM ()+writeTVar (TVar tvar#) val = STM $ \s1# ->+    case writeTVar# tvar# val s1# of+         s2# -> (# s2#, () #)+  +\end{code}++%************************************************************************+%*                                                                      *+\subsection[mvars]{M-Structures}+%*                                                                      *+%************************************************************************++M-Vars are rendezvous points for concurrent threads.  They begin+empty, and any attempt to read an empty M-Var blocks.  When an M-Var+is written, a single blocked thread may be freed.  Reading an M-Var+toggles its state from full back to empty.  Therefore, any value+written to an M-Var may only be read once.  Multiple reads and writes+are allowed, but there must be at least one read between any two+writes.++\begin{code}+--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)++-- |Create an 'MVar' which is initially empty.+newEmptyMVar  :: IO (MVar a)+newEmptyMVar = IO $ \ s# ->+    case newMVar# s# of+         (# s2#, svar# #) -> (# s2#, MVar svar# #)++-- |Create an 'MVar' which contains the supplied value.+newMVar :: a -> IO (MVar a)+newMVar value =+    newEmptyMVar        >>= \ mvar ->+    putMVar mvar value  >>+    return mvar++-- |Return the contents of the 'MVar'.  If the 'MVar' is currently+-- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar', +-- the 'MVar' is left empty.+-- +-- There are two further important properties of 'takeMVar':+--+--   * 'takeMVar' is single-wakeup.  That is, if there are multiple+--     threads blocked in 'takeMVar', and the 'MVar' becomes full,+--     only one thread will be woken up.  The runtime guarantees that+--     the woken thread completes its 'takeMVar' operation.+--+--   * When multiple threads are blocked on an 'MVar', they are+--     woken up in FIFO order.  This is useful for providing+--     fairness properties of abstractions built using 'MVar's.+--+takeMVar :: MVar a -> IO a+takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#++-- |Put a value into an 'MVar'.  If the 'MVar' is currently full,+-- 'putMVar' will wait until it becomes empty.+--+-- There are two further important properties of 'putMVar':+--+--   * 'putMVar' is single-wakeup.  That is, if there are multiple+--     threads blocked in 'putMVar', and the 'MVar' becomes empty,+--     only one thread will be woken up.  The runtime guarantees that+--     the woken thread completes its 'putMVar' operation.+--+--   * When multiple threads are blocked on an 'MVar', they are+--     woken up in FIFO order.  This is useful for providing+--     fairness properties of abstractions built using 'MVar's.+--+putMVar  :: MVar a -> a -> IO ()+putMVar (MVar mvar#) x = IO $ \ s# ->+    case putMVar# mvar# x s# of+        s2# -> (# s2#, () #)++-- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function+-- returns immediately, with 'Nothing' if the 'MVar' was empty, or+-- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',+-- the 'MVar' is left empty.+tryTakeMVar :: MVar a -> IO (Maybe a)+tryTakeMVar (MVar m) = IO $ \ s ->+    case tryTakeMVar# m s of+        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty+        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full++-- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function+-- attempts to put the value @a@ into the 'MVar', returning 'True' if+-- it was successful, or 'False' otherwise.+tryPutMVar  :: MVar a -> a -> IO Bool+tryPutMVar (MVar mvar#) x = IO $ \ s# ->+    case tryPutMVar# mvar# x s# of+        (# s, 0# #) -> (# s, False #)+        (# s, _  #) -> (# s, True #)++-- |Check whether a given 'MVar' is empty.+--+-- Notice that the boolean value returned  is just a snapshot of+-- the state of the MVar. By the time you get to react on its result,+-- the MVar may have been filled (or emptied) - so be extremely+-- careful when using this operation.   Use 'tryTakeMVar' instead if possible.+isEmptyMVar :: MVar a -> IO Bool+isEmptyMVar (MVar mv#) = IO $ \ s# -> +    case isEmptyMVar# mv# s# of+        (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)++-- |Add a finalizer to an 'MVar' (GHC only).  See "Foreign.ForeignPtr" and+-- "System.Mem.Weak" for more about finalizers.+addMVarFinalizer :: MVar a -> IO () -> IO ()+addMVarFinalizer (MVar m) finalizer = +  IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }+\end{code}+++%************************************************************************+%*                                                                      *+\subsection{Thread waiting}+%*                                                                      *+%************************************************************************++\begin{code}+#ifdef mingw32_HOST_OS++-- Note: threadWaitRead and threadWaitWrite aren't really functional+-- on Win32, but left in there because lib code (still) uses them (the manner+-- in which they're used doesn't cause problems on a Win32 platform though.)++asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)+asyncRead  (I# fd) (I# isSock) (I# len) (Ptr buf) =+  IO $ \s -> case asyncRead# fd isSock len buf s of +               (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)++asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)+asyncWrite  (I# fd) (I# isSock) (I# len) (Ptr buf) =+  IO $ \s -> case asyncWrite# fd isSock len buf s of +               (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)++asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int+asyncDoProc (FunPtr proc) (Ptr param) = +    -- the 'length' value is ignored; simplifies implementation of+    -- the async*# primops to have them all return the same result.+  IO $ \s -> case asyncDoProc# proc param s  of +               (# s', _len#, err# #) -> (# s', I# err# #)++-- to aid the use of these primops by the IO Handle implementation,+-- provide the following convenience funs:++-- this better be a pinned byte array!+asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)+asyncReadBA fd isSock len off bufB = +  asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)+  +asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)+asyncWriteBA fd isSock len off bufB = +  asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)++#endif++-- -----------------------------------------------------------------------------+-- Thread IO API++-- | Block the current thread until data is available to read on the+-- given file descriptor (GHC only).+threadWaitRead :: Fd -> IO ()+threadWaitRead fd+#ifndef mingw32_HOST_OS+  | threaded  = waitForReadEvent fd+#endif+  | otherwise = IO $ \s -> +        case fromIntegral fd of { I# fd# ->+        case waitRead# fd# s of { s' -> (# s', () #)+        }}++-- | Block the current thread until data can be written to the+-- given file descriptor (GHC only).+threadWaitWrite :: Fd -> IO ()+threadWaitWrite fd+#ifndef mingw32_HOST_OS+  | threaded  = waitForWriteEvent fd+#endif+  | otherwise = IO $ \s -> +        case fromIntegral fd of { I# fd# ->+        case waitWrite# fd# s of { s' -> (# s', () #)+        }}++-- | Suspends the current thread for a given number of microseconds+-- (GHC only).+--+-- There is no guarantee that the thread will be rescheduled promptly+-- when the delay has expired, but the thread will never continue to+-- run /earlier/ than specified.+--+threadDelay :: Int -> IO ()+threadDelay time+  | threaded  = waitForDelayEvent time+  | otherwise = IO $ \s -> +        case fromIntegral time of { I# time# ->+        case delay# time# s of { s' -> (# s', () #)+        }}+++-- | Set the value of returned TVar to True after a given number of+-- microseconds. The caveats associated with threadDelay also apply.+--+registerDelay :: Int -> IO (TVar Bool)+registerDelay usecs +  | threaded = waitForDelayEventSTM usecs+  | otherwise = error "registerDelay: requires -threaded"++foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool++waitForDelayEvent :: Int -> IO ()+waitForDelayEvent usecs = do+  m <- newEmptyMVar+  target <- calculateTarget usecs+  atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))+  prodServiceThread+  takeMVar m++-- Delays for use in STM+waitForDelayEventSTM :: Int -> IO (TVar Bool)+waitForDelayEventSTM usecs = do+   t <- atomically $ newTVar False+   target <- calculateTarget usecs+   atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))+   prodServiceThread+   return t  +    +calculateTarget :: Int -> IO USecs+calculateTarget usecs = do+    now <- getUSecOfDay+    return $ now + (fromIntegral usecs)+++-- ----------------------------------------------------------------------------+-- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay++-- In the threaded RTS, we employ a single IO Manager thread to wait+-- for all outstanding IO requests (threadWaitRead,threadWaitWrite)+-- and delays (threadDelay).  +--+-- We can do this because in the threaded RTS the IO Manager can make+-- a non-blocking call to select(), so we don't have to do select() in+-- the scheduler as we have to in the non-threaded RTS.  We get performance+-- benefits from doing it this way, because we only have to restart the select()+-- when a new request arrives, rather than doing one select() each time+-- around the scheduler loop.  Furthermore, the scheduler can be simplified+-- by not having to check for completed IO requests.++-- Issues, possible problems:+--+--      - we might want bound threads to just do the blocking+--        operation rather than communicating with the IO manager+--        thread.  This would prevent simgle-threaded programs which do+--        IO from requiring multiple OS threads.  However, it would also+--        prevent bound threads waiting on IO from being killed or sent+--        exceptions.+--+--      - Apprently exec() doesn't work on Linux in a multithreaded program.+--        I couldn't repeat this.+--+--      - How do we handle signal delivery in the multithreaded RTS?+--+--      - forkProcess will kill the IO manager thread.  Let's just+--        hope we don't need to do any blocking IO between fork & exec.++#ifndef mingw32_HOST_OS+data IOReq+  = Read   {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())+  | Write  {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())+#endif++data DelayReq+  = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())+  | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)++#ifndef mingw32_HOST_OS+pendingEvents :: IORef [IOReq]+#endif+pendingDelays :: IORef [DelayReq]+        -- could use a strict list or array here+{-# NOINLINE pendingEvents #-}+{-# NOINLINE pendingDelays #-}+(pendingEvents,pendingDelays) = unsafePerformIO $ do+  startIOManagerThread+  reqs <- newIORef []+  dels <- newIORef []+  return (reqs, dels)+        -- the first time we schedule an IO request, the service thread+        -- will be created (cool, huh?)++ensureIOManagerIsRunning :: IO ()+ensureIOManagerIsRunning +  | threaded  = seq pendingEvents $ return ()+  | otherwise = return ()++insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]+insertDelay d [] = [d]+insertDelay d1 ds@(d2 : rest)+  | delayTime d1 <= delayTime d2 = d1 : ds+  | otherwise                    = d2 : insertDelay d1 rest++delayTime :: DelayReq -> USecs+delayTime (Delay t _) = t+delayTime (DelaySTM t _) = t++type USecs = Word64++-- XXX: move into GHC.IOBase from Data.IORef?+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s++foreign import ccall unsafe "getUSecOfDay" +  getUSecOfDay :: IO USecs++prodding :: IORef Bool+{-# NOINLINE prodding #-}+prodding = unsafePerformIO (newIORef False)++prodServiceThread :: IO ()+prodServiceThread = do+  was_set <- atomicModifyIORef prodding (\a -> (True,a))+  if (not (was_set)) then wakeupIOManager else return ()++#ifdef mingw32_HOST_OS+-- ----------------------------------------------------------------------------+-- Windows IO manager thread++startIOManagerThread :: IO ()+startIOManagerThread = do+  wakeup <- c_getIOManagerEvent+  forkIO $ service_loop wakeup []+  return ()++service_loop :: HANDLE          -- read end of pipe+             -> [DelayReq]      -- current delay requests+             -> IO ()++service_loop wakeup old_delays = do+  -- pick up new delay requests+  new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))+  let  delays = foldr insertDelay old_delays new_delays++  now <- getUSecOfDay+  (delays', timeout) <- getDelay now delays++  r <- c_WaitForSingleObject wakeup timeout+  case r of+    0xffffffff -> do c_maperrno; throwErrno "service_loop"+    0 -> do+        r2 <- c_readIOManagerEvent+        exit <- +              case r2 of+                _ | r2 == io_MANAGER_WAKEUP -> return False+                _ | r2 == io_MANAGER_DIE    -> return True+                0 -> return False -- spurious wakeup+                _ -> do start_console_handler (r2 `shiftR` 1); return False+        if exit+          then return ()+          else service_cont wakeup delays'++    _other -> service_cont wakeup delays' -- probably timeout        ++service_cont :: HANDLE -> [DelayReq] -> IO ()+service_cont wakeup delays = do+  r <- atomicModifyIORef prodding (\_ -> (False,False))+  r `seq` return () -- avoid space leak+  service_loop wakeup delays++-- must agree with rts/win32/ThrIOManager.c+io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32+io_MANAGER_WAKEUP = 0xffffffff+io_MANAGER_DIE    = 0xfffffffe++data ConsoleEvent+ = ControlC+ | Break+ | Close+    -- these are sent to Services only.+ | Logoff+ | Shutdown+ deriving (Eq, Ord, Enum, Show, Read, Typeable)++start_console_handler :: Word32 -> IO ()+start_console_handler r =+  case toWin32ConsoleEvent r of+     Just x  -> withMVar win32ConsoleHandler $ \handler -> do+                    forkIO (handler x)+                    return ()+     Nothing -> return ()++toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent+toWin32ConsoleEvent ev = +   case ev of+       0 {- CTRL_C_EVENT-}        -> Just ControlC+       1 {- CTRL_BREAK_EVENT-}    -> Just Break+       2 {- CTRL_CLOSE_EVENT-}    -> Just Close+       5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff+       6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown+       _ -> Nothing++win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())+win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))++-- XXX Is this actually needed?+stick :: IORef HANDLE+{-# NOINLINE stick #-}+stick = unsafePerformIO (newIORef nullPtr)++wakeupIOManager :: IO ()+wakeupIOManager = do +  _hdl <- readIORef stick+  c_sendIOManagerEvent io_MANAGER_WAKEUP++-- Walk the queue of pending delays, waking up any that have passed+-- and return the smallest delay to wait for.  The queue of pending+-- delays is kept ordered.+getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)+getDelay _   [] = return ([], iNFINITE)+getDelay now all@(d : rest) +  = case d of+     Delay time m | now >= time -> do+        putMVar m ()+        getDelay now rest+     DelaySTM time t | now >= time -> do+        atomically $ writeTVar t True+        getDelay now rest+     _otherwise ->+        -- delay is in millisecs for WaitForSingleObject+        let micro_seconds = delayTime d - now+            milli_seconds = (micro_seconds + 999) `div` 1000+        in return (all, fromIntegral milli_seconds)++-- ToDo: this just duplicates part of System.Win32.Types, which isn't+-- available yet.  We should move some Win32 functionality down here,+-- maybe as part of the grand reorganisation of the base package...+type HANDLE       = Ptr ()+type DWORD        = Word32++iNFINITE :: DWORD+iNFINITE = 0xFFFFFFFF -- urgh++foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)+  c_getIOManagerEvent :: IO HANDLE++foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)+  c_readIOManagerEvent :: IO Word32++foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)+  c_sendIOManagerEvent :: Word32 -> IO ()++foreign import ccall unsafe "maperrno"             -- in Win32Utils.c+   c_maperrno :: IO ()++foreign import stdcall "WaitForSingleObject"+   c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD++#else+-- ----------------------------------------------------------------------------+-- Unix IO manager thread, using select()++startIOManagerThread :: IO ()+startIOManagerThread = do+        allocaArray 2 $ \fds -> do+        throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)+        rd_end <- peekElemOff fds 0+        wr_end <- peekElemOff fds 1+        setNonBlockingFD wr_end -- writes happen in a signal handler, we+                                -- don't want them to block.+        setCloseOnExec rd_end+        setCloseOnExec wr_end+        writeIORef stick (fromIntegral wr_end)+        c_setIOManagerPipe wr_end+        forkIO $ do+            allocaBytes sizeofFdSet   $ \readfds -> do+            allocaBytes sizeofFdSet   $ \writefds -> do +            allocaBytes sizeofTimeVal $ \timeval -> do+            service_loop (fromIntegral rd_end) readfds writefds timeval [] []+        return ()++service_loop+   :: Fd                -- listen to this for wakeup calls+   -> Ptr CFdSet+   -> Ptr CFdSet+   -> Ptr CTimeVal+   -> [IOReq]+   -> [DelayReq]+   -> IO ()+service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do++  -- pick up new IO requests+  new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))+  let reqs = new_reqs ++ old_reqs++  -- pick up new delay requests+  new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))+  let  delays0 = foldr insertDelay old_delays new_delays++  -- build the FDSets for select()+  fdZero readfds+  fdZero writefds+  fdSet wakeup readfds+  maxfd <- buildFdSets 0 readfds writefds reqs++  -- perform the select()+  let do_select delays = do+          -- check the current time and wake up any thread in+          -- threadDelay whose timeout has expired.  Also find the+          -- timeout value for the select() call.+          now <- getUSecOfDay+          (delays', timeout) <- getDelay now ptimeval delays++          res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds +                        nullPtr timeout+          if (res == -1)+             then do+                err <- getErrno+                case err of+                  _ | err == eINTR ->  do_select delays'+                        -- EINTR: just redo the select()+                  _ | err == eBADF ->  return (True, delays)+                        -- EBADF: one of the file descriptors is closed or bad,+                        -- we don't know which one, so wake everyone up.+                  _ | otherwise    ->  throwErrno "select"+                        -- otherwise (ENOMEM or EINVAL) something has gone+                        -- wrong; report the error.+             else+                return (False,delays')++  (wakeup_all,delays') <- do_select delays0++  exit <-+    if wakeup_all then return False+      else do+        b <- fdIsSet wakeup readfds+        if b == 0 +          then return False+          else alloca $ \p -> do +                 c_read (fromIntegral wakeup) p 1+                 s <- peek p            +                 case s of+                  _ | s == io_MANAGER_WAKEUP -> return False+                  _ | s == io_MANAGER_DIE    -> return True+                  _ | s == io_MANAGER_SYNC   -> do+                       mvars <- readIORef sync+                       mapM_ (flip putMVar ()) mvars+                       return False+                  _ -> do+                       fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)+                       withForeignPtr fp $ \p_siginfo -> do+                         r <- c_read (fromIntegral wakeup) (castPtr p_siginfo)+                                 sizeof_siginfo_t+                         when (r /= fromIntegral sizeof_siginfo_t) $+                            error "failed to read siginfo_t"+                       runHandlers' fp (fromIntegral s)+                       return False++  if exit then return () else do++  atomicModifyIORef prodding (\_ -> (False,False))++  reqs' <- if wakeup_all then do wakeupAll reqs; return []+                         else completeRequests reqs readfds writefds []++  service_loop wakeup readfds writefds ptimeval reqs' delays'++io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: CChar+io_MANAGER_WAKEUP = 0xff+io_MANAGER_DIE    = 0xfe+io_MANAGER_SYNC   = 0xfd++-- | the stick is for poking the IO manager with+stick :: IORef Fd+{-# NOINLINE stick #-}+stick = unsafePerformIO (newIORef 0)++{-# NOINLINE sync #-}+sync :: IORef [MVar ()]+sync = unsafePerformIO (newIORef [])++-- waits for the IO manager to drain the pipe+syncIOManager :: IO ()+syncIOManager = do+  m <- newEmptyMVar+  atomicModifyIORef sync (\old -> (m:old,()))+  fd <- readIORef stick+  with io_MANAGER_SYNC $ \pbuf -> do +    c_write (fromIntegral fd) pbuf 1; return ()+  takeMVar m++wakeupIOManager :: IO ()+wakeupIOManager = do+  fd <- readIORef stick+  with io_MANAGER_WAKEUP $ \pbuf -> do +    c_write (fromIntegral fd) pbuf 1; return ()++-- For the non-threaded RTS+runHandlers :: Ptr Word8 -> Int -> IO ()+runHandlers p_info sig = do+  fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)+  withForeignPtr fp $ \p -> do+    copyBytes p p_info (fromIntegral sizeof_siginfo_t)+    free p_info+  runHandlers' fp (fromIntegral sig)++runHandlers' :: ForeignPtr Word8 -> Signal -> IO ()+runHandlers' p_info sig = do+  let int = fromIntegral sig+  withMVar signal_handlers $ \arr ->+      if not (inRange (boundsIOArray arr) int)+         then return ()+         else do handler <- unsafeReadIOArray arr int+                 case handler of+                    Nothing -> return ()+                    Just (f,_)  -> do forkIO (f p_info); return ()++foreign import ccall "setIOManagerPipe"+  c_setIOManagerPipe :: CInt -> IO ()++foreign import ccall "__hscore_sizeof_siginfo_t"+  sizeof_siginfo_t :: CSize++type Signal = CInt++maxSig = 64 :: Int++type HandlerFun = ForeignPtr Word8 -> IO ()++-- Lock used to protect concurrent access to signal_handlers.  Symptom of+-- this race condition is #1922, although that bug was on Windows a similar+-- bug also exists on Unix.+{-# NOINLINE signal_handlers #-}+signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))+signal_handlers = unsafePerformIO $ do+   arr <- newIOArray (0,maxSig) Nothing+   newMVar arr++setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic))+setHandler sig handler = do+  let int = fromIntegral sig+  withMVar signal_handlers $ \arr -> +     if not (inRange (boundsIOArray arr) int)+        then error "GHC.Conc.setHandler: signal out of range"+        else do old <- unsafeReadIOArray arr int+                unsafeWriteIOArray arr int handler+                return old++-- -----------------------------------------------------------------------------+-- IO requests++buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd+buildFdSets maxfd _       _        [] = return maxfd+buildFdSets maxfd readfds writefds (Read fd _ : reqs)+  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"+  | otherwise        =  do+        fdSet fd readfds+        buildFdSets (max maxfd fd) readfds writefds reqs+buildFdSets maxfd readfds writefds (Write fd _ : reqs)+  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"+  | otherwise        =  do+        fdSet fd writefds+        buildFdSets (max maxfd fd) readfds writefds reqs++completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]+                 -> IO [IOReq]+completeRequests [] _ _ reqs' = return reqs'+completeRequests (Read fd m : reqs) readfds writefds reqs' = do+  b <- fdIsSet fd readfds+  if b /= 0+    then do putMVar m (); completeRequests reqs readfds writefds reqs'+    else completeRequests reqs readfds writefds (Read fd m : reqs')+completeRequests (Write fd m : reqs) readfds writefds reqs' = do+  b <- fdIsSet fd writefds+  if b /= 0+    then do putMVar m (); completeRequests reqs readfds writefds reqs'+    else completeRequests reqs readfds writefds (Write fd m : reqs')++wakeupAll :: [IOReq] -> IO ()+wakeupAll [] = return ()+wakeupAll (Read  _ m : reqs) = do putMVar m (); wakeupAll reqs+wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs++waitForReadEvent :: Fd -> IO ()+waitForReadEvent fd = do+  m <- newEmptyMVar+  atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))+  prodServiceThread+  takeMVar m++waitForWriteEvent :: Fd -> IO ()+waitForWriteEvent fd = do+  m <- newEmptyMVar+  atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))+  prodServiceThread+  takeMVar m++-- -----------------------------------------------------------------------------+-- Delays++-- Walk the queue of pending delays, waking up any that have passed+-- and return the smallest delay to wait for.  The queue of pending+-- delays is kept ordered.+getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)+getDelay _   _        [] = return ([],nullPtr)+getDelay now ptimeval all@(d : rest) +  = case d of+     Delay time m | now >= time -> do+        putMVar m ()+        getDelay now ptimeval rest+     DelaySTM time t | now >= time -> do+        atomically $ writeTVar t True+        getDelay now ptimeval rest+     _otherwise -> do+        setTimevalTicks ptimeval (delayTime d - now)+        return (all,ptimeval)++data CTimeVal++foreign import ccall unsafe "sizeofTimeVal"+  sizeofTimeVal :: Int++foreign import ccall unsafe "setTimevalTicks" +  setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()++{- +  On Win32 we're going to have a single Pipe, and a+  waitForSingleObject with the delay time.  For signals, we send a+  byte down the pipe just like on Unix.+-}++-- ----------------------------------------------------------------------------+-- select() interface++-- ToDo: move to System.Posix.Internals?++data CFdSet++foreign import ccall safe "select"+  c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal+           -> IO CInt++foreign import ccall unsafe "hsFD_SETSIZE"+  c_fD_SETSIZE :: CInt++fD_SETSIZE :: Fd+fD_SETSIZE = fromIntegral c_fD_SETSIZE++foreign import ccall unsafe "hsFD_ISSET"+  c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt++fdIsSet :: Fd -> Ptr CFdSet -> IO CInt+fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset++foreign import ccall unsafe "hsFD_SET"+  c_fdSet :: CInt -> Ptr CFdSet -> IO ()++fdSet :: Fd -> Ptr CFdSet -> IO ()+fdSet (Fd fd) fdset = c_fdSet fd fdset++foreign import ccall unsafe "hsFD_ZERO"+  fdZero :: Ptr CFdSet -> IO ()++foreign import ccall unsafe "sizeof_fd_set"+  sizeofFdSet :: Int++#endif++reportStackOverflow :: IO a+reportStackOverflow = do callStackOverflowHook; return undefined++reportError :: SomeException -> IO a+reportError ex = do+   handler <- getUncaughtExceptionHandler+   handler ex+   return undefined++-- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove+-- the unsafe below.+foreign import ccall unsafe "stackOverflow"+        callStackOverflowHook :: IO ()++{-# NOINLINE uncaughtExceptionHandler #-}+uncaughtExceptionHandler :: IORef (SomeException -> IO ())+uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)+   where+      defaultHandler :: SomeException -> IO ()+      defaultHandler se@(SomeException ex) = do+         (hFlush stdout) `catchAny` (\ _ -> return ())+         let msg = case cast ex of+               Just Deadlock -> "no threads to run:  infinite loop or deadlock?"+               _ -> case cast ex of+                    Just (ErrorCall s) -> s+                    _                  -> showsPrec 0 se ""+         withCString "%s" $ \cfmt ->+          withCString msg $ \cmsg ->+            errorBelch cfmt cmsg++-- don't use errorBelch() directly, because we cannot call varargs functions+-- using the FFI.+foreign import ccall unsafe "HsBase.h errorBelch2"+   errorBelch :: CString -> CString -> IO ()++setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler++getUncaughtExceptionHandler :: IO (SomeException -> IO ())+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler+++withMVar :: MVar a -> (a -> IO b) -> IO b+withMVar m io = +  block $ do+    a <- takeMVar m+    b <- catchAny (unblock (io a))+            (\e -> do putMVar m a; throw e)+    putMVar m a+    return b+\end{code}
+ lib/base/src/GHC/Enum.lhs view
@@ -0,0 +1,586 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Enum+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- The 'Enum' and 'Bounded' classes.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Enum(+        Bounded(..), Enum(..),+        boundedEnumFrom, boundedEnumFromThen,++        -- Instances for Bounded and Enum: (), Char, Int++   ) where++import GHC.Base+import Data.Tuple       ()              -- for dependencies+default ()              -- Double isn't available yet+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Class declarations}+%*                                                      *+%*********************************************************++\begin{code}+-- | The 'Bounded' class is used to name the upper and lower limits of a+-- type.  'Ord' is not a superclass of 'Bounded' since types that are not+-- totally ordered may also have upper and lower bounds.+--+-- The 'Bounded' class may be derived for any enumeration type;+-- 'minBound' is the first constructor listed in the @data@ declaration+-- and 'maxBound' is the last.+-- 'Bounded' may also be derived for single-constructor datatypes whose+-- constituent types are in 'Bounded'.++class  Bounded a  where+    minBound, maxBound :: a++-- | Class 'Enum' defines operations on sequentially ordered types.+--+-- The @enumFrom@... methods are used in Haskell's translation of+-- arithmetic sequences.+--+-- Instances of 'Enum' may be derived for any enumeration type (types+-- whose constructors have no fields).  The nullary constructors are+-- assumed to be numbered left-to-right by 'fromEnum' from @0@ through @n-1@.+-- See Chapter 10 of the /Haskell Report/ for more details.+--  +-- For any type that is an instance of class 'Bounded' as well as 'Enum',+-- the following should hold:+--+-- * The calls @'succ' 'maxBound'@ and @'pred' 'minBound'@ should result in+--   a runtime error.+-- +-- * 'fromEnum' and 'toEnum' should give a runtime error if the +--   result value is not representable in the result type.+--   For example, @'toEnum' 7 :: 'Bool'@ is an error.+--+-- * 'enumFrom' and 'enumFromThen' should be defined with an implicit bound,+--   thus:+--+-- >    enumFrom     x   = enumFromTo     x maxBound+-- >    enumFromThen x y = enumFromThenTo x y bound+-- >      where+-- >        bound | fromEnum y >= fromEnum x = maxBound+-- >              | otherwise                = minBound+--+class  Enum a   where+    -- | the successor of a value.  For numeric types, 'succ' adds 1.+    succ                :: a -> a+    -- | the predecessor of a value.  For numeric types, 'pred' subtracts 1.+    pred                :: a -> a+    -- | Convert from an 'Int'.+    toEnum              :: Int -> a+    -- | Convert to an 'Int'.+    -- It is implementation-dependent what 'fromEnum' returns when+    -- applied to a value that is too large to fit in an 'Int'.+    fromEnum            :: a -> Int++    -- | Used in Haskell's translation of @[n..]@.+    enumFrom            :: a -> [a]+    -- | Used in Haskell's translation of @[n,n'..]@.+    enumFromThen        :: a -> a -> [a]+    -- | Used in Haskell's translation of @[n..m]@.+    enumFromTo          :: a -> a -> [a]+    -- | Used in Haskell's translation of @[n,n'..m]@.+    enumFromThenTo      :: a -> a -> a -> [a]++    succ                   = toEnum . (`plusInt` oneInt)  . fromEnum+    pred                   = toEnum . (`minusInt` oneInt) . fromEnum+    enumFrom x             = map toEnum [fromEnum x ..]+    enumFromThen x y       = map toEnum [fromEnum x, fromEnum y ..]+    enumFromTo x y         = map toEnum [fromEnum x .. fromEnum y]+    enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]++-- Default methods for bounded enumerations+boundedEnumFrom :: (Enum a, Bounded a) => a -> [a]+boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)]++boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a]+boundedEnumFromThen n1 n2 +  | i_n2 >= i_n1  = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)]+  | otherwise     = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)]+  where+    i_n1 = fromEnum n1+    i_n2 = fromEnum n2+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Tuples}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded () where+    minBound = ()+    maxBound = ()++instance Enum () where+    succ _      = error "Prelude.Enum.().succ: bad argument"+    pred _      = error "Prelude.Enum.().pred: bad argument"++    toEnum x | x == zeroInt = ()+             | otherwise    = error "Prelude.Enum.().toEnum: bad argument"++    fromEnum () = zeroInt+    enumFrom ()         = [()]+    enumFromThen () ()  = let many = ():many in many+    enumFromTo () ()    = [()]+    enumFromThenTo () () () = let many = ():many in many+\end{code}++\begin{code}+-- Report requires instances up to 15+instance (Bounded a, Bounded b) => Bounded (a,b) where+   minBound = (minBound, minBound)+   maxBound = (maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c) => Bounded (a,b,c) where+   minBound = (minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a,b,c,d) where+   minBound = (minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e) => Bounded (a,b,c,d,e) where+   minBound = (minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f)+        => Bounded (a,b,c,d,e,f) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g)+        => Bounded (a,b,c,d,e,f,g) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h)+        => Bounded (a,b,c,d,e,f,g,h) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i)+        => Bounded (a,b,c,d,e,f,g,h,i) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i, Bounded j)+        => Bounded (a,b,c,d,e,f,g,h,i,j) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i, Bounded j, Bounded k)+        => Bounded (a,b,c,d,e,f,g,h,i,j,k) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i, Bounded j, Bounded k, Bounded l)+        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m)+        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n)+        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,+          Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o)+        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Bool@}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded Bool where+  minBound = False+  maxBound = True++instance Enum Bool where+  succ False = True+  succ True  = error "Prelude.Enum.Bool.succ: bad argument"++  pred True  = False+  pred False  = error "Prelude.Enum.Bool.pred: bad argument"++  toEnum n | n == zeroInt = False+           | n == oneInt  = True+           | otherwise    = error "Prelude.Enum.Bool.toEnum: bad argument"++  fromEnum False = zeroInt+  fromEnum True  = oneInt++  -- Use defaults for the rest+  enumFrom     = boundedEnumFrom+  enumFromThen = boundedEnumFromThen+\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Ordering@}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded Ordering where+  minBound = LT+  maxBound = GT++instance Enum Ordering where+  succ LT = EQ+  succ EQ = GT+  succ GT = error "Prelude.Enum.Ordering.succ: bad argument"++  pred GT = EQ+  pred EQ = LT+  pred LT = error "Prelude.Enum.Ordering.pred: bad argument"++  toEnum n | n == zeroInt = LT+           | n == oneInt  = EQ+           | n == twoInt  = GT+  toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument"++  fromEnum LT = zeroInt+  fromEnum EQ = oneInt+  fromEnum GT = twoInt++  -- Use defaults for the rest+  enumFrom     = boundedEnumFrom+  enumFromThen = boundedEnumFromThen+\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Char@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Bounded Char  where+    minBound =  '\0'+    maxBound =  '\x10FFFF'++instance  Enum Char  where+    succ (C# c#)+       | not (ord# c# ==# 0x10FFFF#) = C# (chr# (ord# c# +# 1#))+       | otherwise              = error ("Prelude.Enum.Char.succ: bad argument")+    pred (C# c#)+       | not (ord# c# ==# 0#)   = C# (chr# (ord# c# -# 1#))+       | otherwise              = error ("Prelude.Enum.Char.pred: bad argument")++    toEnum   = chr+    fromEnum = ord++    {-# INLINE enumFrom #-}+    enumFrom (C# x) = eftChar (ord# x) 0x10FFFF#+        -- Blarg: technically I guess enumFrom isn't strict!++    {-# INLINE enumFromTo #-}+    enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y)+    +    {-# INLINE enumFromThen #-}+    enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2)+    +    {-# INLINE enumFromThenTo #-}+    enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y)++{-# RULES+"eftChar"       [~1] forall x y.        eftChar x y       = build (\c n -> eftCharFB c n x y)+"efdChar"       [~1] forall x1 x2.      efdChar x1 x2     = build (\ c n -> efdCharFB c n x1 x2)+"efdtChar"      [~1] forall x1 x2 l.    efdtChar x1 x2 l  = build (\ c n -> efdtCharFB c n x1 x2 l)+"eftCharList"   [1]  eftCharFB  (:) [] = eftChar+"efdCharList"   [1]  efdCharFB  (:) [] = efdChar+"efdtCharList"  [1]  efdtCharFB (:) [] = efdtChar+ #-}+++-- We can do better than for Ints because we don't+-- have hassles about arithmetic overflow at maxBound+{-# INLINE [0] eftCharFB #-}+eftCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a+eftCharFB c n x0 y = go x0+                 where+                    go x | x ># y    = n+                         | otherwise = C# (chr# x) `c` go (x +# 1#)++eftChar :: Int# -> Int# -> String+eftChar x y | x ># y    = []+            | otherwise = C# (chr# x) : eftChar (x +# 1#) y+++-- For enumFromThenTo we give up on inlining+{-# NOINLINE [0] efdCharFB #-}+efdCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a+efdCharFB c n x1 x2+  | delta >=# 0# = go_up_char_fb c n x1 delta 0x10FFFF#+  | otherwise    = go_dn_char_fb c n x1 delta 0#+  where+    delta = x2 -# x1++efdChar :: Int# -> Int# -> String+efdChar x1 x2+  | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF#+  | otherwise    = go_dn_char_list x1 delta 0#+  where+    delta = x2 -# x1++{-# NOINLINE [0] efdtCharFB #-}+efdtCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a+efdtCharFB c n x1 x2 lim+  | delta >=# 0# = go_up_char_fb c n x1 delta lim+  | otherwise    = go_dn_char_fb c n x1 delta lim+  where+    delta = x2 -# x1++efdtChar :: Int# -> Int# -> Int# -> String+efdtChar x1 x2 lim+  | delta >=# 0# = go_up_char_list x1 delta lim+  | otherwise    = go_dn_char_list x1 delta lim+  where+    delta = x2 -# x1++go_up_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a+go_up_char_fb c n x0 delta lim+  = go_up x0+  where+    go_up x | x ># lim  = n+            | otherwise = C# (chr# x) `c` go_up (x +# delta)++go_dn_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a+go_dn_char_fb c n x0 delta lim+  = go_dn x0+  where+    go_dn x | x <# lim  = n+            | otherwise = C# (chr# x) `c` go_dn (x +# delta)++go_up_char_list :: Int# -> Int# -> Int# -> String+go_up_char_list x0 delta lim+  = go_up x0+  where+    go_up x | x ># lim  = []+            | otherwise = C# (chr# x) : go_up (x +# delta)++go_dn_char_list :: Int# -> Int# -> Int# -> String+go_dn_char_list x0 delta lim+  = go_dn x0+  where+    go_dn x | x <# lim  = []+            | otherwise = C# (chr# x) : go_dn (x +# delta)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Int@}+%*                                                      *+%*********************************************************++Be careful about these instances.  +        (a) remember that you have to count down as well as up e.g. [13,12..0]+        (b) be careful of Int overflow+        (c) remember that Int is bounded, so [1..] terminates at maxInt++Also NB that the Num class isn't available in this module.+        +\begin{code}+instance  Bounded Int where+    minBound =  minInt+    maxBound =  maxInt++instance  Enum Int  where+    succ x  +       | x == maxBound  = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"+       | otherwise      = x `plusInt` oneInt+    pred x+       | x == minBound  = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"+       | otherwise      = x `minusInt` oneInt++    toEnum   x = x+    fromEnum x = x++    {-# INLINE enumFrom #-}+    enumFrom (I# x) = eftInt x maxInt#+        where I# maxInt# = maxInt+        -- Blarg: technically I guess enumFrom isn't strict!++    {-# INLINE enumFromTo #-}+    enumFromTo (I# x) (I# y) = eftInt x y++    {-# INLINE enumFromThen #-}+    enumFromThen (I# x1) (I# x2) = efdInt x1 x2++    {-# INLINE enumFromThenTo #-}+    enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y+++-----------------------------------------------------+-- eftInt and eftIntFB deal with [a..b], which is the +-- most common form, so we take a lot of care+-- In particular, we have rules for deforestation++{-# RULES+"eftInt"        [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+"eftIntList"    [1] eftIntFB  (:) [] = eftInt+ #-}++eftInt :: Int# -> Int# -> [Int]+-- [x1..x2]+eftInt x0 y | x0 ># y    = []+            | otherwise = go x0+               where+                 go x = I# x : if x ==# y then [] else go (x +# 1#)++{-# INLINE [0] eftIntFB #-}+eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+eftIntFB c n x0 y | x0 ># y    = n        +                  | otherwise = go x0+                 where+                   go x = I# x `c` if x ==# y then n else go (x +# 1#)+                        -- Watch out for y=maxBound; hence ==, not >+        -- Be very careful not to have more than one "c"+        -- so that when eftInfFB is inlined we can inline+        -- whatever is bound to "c"+++-----------------------------------------------------+-- efdInt and efdtInt deal with [a,b..] and [a,b..c].+-- The code is more complicated because of worries about Int overflow.++{-# RULES+"efdtInt"       [~1] forall x1 x2 y.+                     efdtInt x1 x2 y = build (\ c n -> efdtIntFB c n x1 x2 y)+"efdtIntUpList" [1]  efdtIntFB (:) [] = efdtInt+ #-}++efdInt :: Int# -> Int# -> [Int]+-- [x1,x2..maxInt]+efdInt x1 x2 + | x2 >=# x1 = case maxInt of I# y -> efdtIntUp x1 x2 y+ | otherwise = case minInt of I# y -> efdtIntDn x1 x2 y++efdtInt :: Int# -> Int# -> Int# -> [Int]+-- [x1,x2..y]+efdtInt x1 x2 y+ | x2 >=# x1 = efdtIntUp x1 x2 y+ | otherwise = efdtIntDn x1 x2 y++{-# INLINE [0] efdtIntFB #-}+efdtIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r+efdtIntFB c n x1 x2 y+ | x2 >=# x1  = efdtIntUpFB c n x1 x2 y+ | otherwise  = efdtIntDnFB c n x1 x2 y++-- Requires x2 >= x1+efdtIntUp :: Int# -> Int# -> Int# -> [Int]+efdtIntUp x1 x2 y    -- Be careful about overflow!+ | y <# x2   = if y <# x1 then [] else [I# x1]+ | otherwise = -- Common case: x1 <= x2 <= y+               let delta = x2 -# x1 -- >= 0+                   y' = y -# delta  -- x1 <= y' <= y; hence y' is representable++                   -- Invariant: x <= y+                   -- Note that: z <= y' => z + delta won't overflow+                   -- so we are guaranteed not to overflow if/when we recurse+                   go_up x | x ># y'  = [I# x]+                           | otherwise = I# x : go_up (x +# delta)+               in I# x1 : go_up x2++-- Requires x2 >= x1+efdtIntUpFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r+efdtIntUpFB c n x1 x2 y    -- Be careful about overflow!+ | y <# x2   = if y <# x1 then n else I# x1 `c` n+ | otherwise = -- Common case: x1 <= x2 <= y+               let delta = x2 -# x1 -- >= 0+                   y' = y -# delta  -- x1 <= y' <= y; hence y' is representable++                   -- Invariant: x <= y+                   -- Note that: z <= y' => z + delta won't overflow+                   -- so we are guaranteed not to overflow if/when we recurse+                   go_up x | x ># y'   = I# x `c` n+                           | otherwise = I# x `c` go_up (x +# delta)+               in I# x1 `c` go_up x2++-- Requires x2 <= x1+efdtIntDn :: Int# -> Int# -> Int# -> [Int]+efdtIntDn x1 x2 y    -- Be careful about underflow!+ | y ># x2   = if y ># x1 then [] else [I# x1]+ | otherwise = -- Common case: x1 >= x2 >= y+               let delta = x2 -# x1 -- <= 0+                   y' = y -# delta  -- y <= y' <= x1; hence y' is representable++                   -- Invariant: x >= y+                   -- Note that: z >= y' => z + delta won't underflow+                   -- so we are guaranteed not to underflow if/when we recurse+                   go_dn x | x <# y'  = [I# x]+                           | otherwise = I# x : go_dn (x +# delta)+   in I# x1 : go_dn x2++-- Requires x2 <= x1+efdtIntDnFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r+efdtIntDnFB c n x1 x2 y    -- Be careful about underflow!+ | y ># x2 = if y ># x1 then n else I# x1 `c` n+ | otherwise = -- Common case: x1 >= x2 >= y+               let delta = x2 -# x1 -- <= 0+                   y' = y -# delta  -- y <= y' <= x1; hence y' is representable++                   -- Invariant: x >= y+                   -- Note that: z >= y' => z + delta won't underflow+                   -- so we are guaranteed not to underflow if/when we recurse+                   go_dn x | x <# y'   = I# x `c` n+                           | otherwise = I# x `c` go_dn (x +# delta)+               in I# x1 `c` go_dn x2+\end{code}+
+ lib/base/src/GHC/Err.lhs view
@@ -0,0 +1,89 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Err+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- The "GHC.Err" module defines the code for the wired-in error functions,+-- which have a special type in the compiler (with \"open tyvars\").+-- +-- We cannot define these functions in a module where they might be used+-- (e.g., "GHC.Base"), because the magical wired-in type will get confused+-- with what the typechecker figures out.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Err+       (+         absentErr                 -- :: a+       , divZeroError              -- :: a+       , overflowError             -- :: a++       , error                     -- :: String -> a++       , undefined                 -- :: a+       ) where++#ifndef __HADDOCK__+import GHC.Types+import GHC.Exception+#endif+\end{code}++%*********************************************************+%*                                                      *+\subsection{Error-ish functions}+%*                                                      *+%*********************************************************++\begin{code}+-- | 'error' stops execution and displays an error message.+error :: [Char] -> a+error s = throw (ErrorCall s)++-- | A special case of 'error'.+-- It is expected that compilers will recognize this and insert error+-- messages which are more appropriate to the context in which 'undefined'+-- appears. ++undefined :: a+undefined =  error "Prelude.undefined"+\end{code}++%*********************************************************+%*                                                       *+\subsection{Compiler generated errors + local utils}+%*                                                       *+%*********************************************************++Used for compiler-generated error message;+encoding saves bytes of string junk.++\begin{code}+absentErr :: a++absentErr = error "Oops! The program has entered an `absent' argument!\n"+\end{code}++Divide by zero and arithmetic overflow.+We put them here because they are needed relatively early+in the libraries before the Exception type has been defined yet.++\begin{code}+{-# NOINLINE divZeroError #-}+divZeroError :: a+divZeroError = throw DivideByZero++{-# NOINLINE overflowError #-}+overflowError :: a+overflowError = throw Overflow+\end{code}+
+ lib/base/src/GHC/Err.lhs-boot view
@@ -0,0 +1,26 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+---------------------------------------------------------------------------+--                  Ghc.Err.hs-boot+---------------------------------------------------------------------------++module GHC.Err( error, divZeroError, overflowError ) where++-- The type signature for 'error' is a gross hack.+-- First, we can't give an accurate type for error, because it mentions +-- an open type variable.+-- Second, we can't even say error :: [Char] -> a, because Char is defined+-- in GHC.Base, and that would make Err.lhs-boot mutually recursive +-- with GHC.Base.+-- Fortunately it doesn't matter what type we give here because the +-- compiler will use its wired-in version.  But we have+-- to mention 'error' so that it gets exported from this .hi-boot+-- file.+error    :: a++-- divide by zero is needed quite early+divZeroError :: a++-- overflow is needed quite early+overflowError :: a+\end{code}
+ lib/base/src/GHC/Exception.lhs view
@@ -0,0 +1,189 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Exception+-- Copyright   :  (c) The University of Glasgow, 1998-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Exceptions and exception-handling functions.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Exception where++import Data.Maybe+import {-# SOURCE #-} Data.Typeable+import GHC.Base+import GHC.Show+\end{code}++%*********************************************************+%*                                                      *+\subsection{Exceptions}+%*                                                      *+%*********************************************************++\begin{code}+{- |+The @SomeException@ type is the root of the exception type hierarchy.+When an exception of type @e@ is thrown, behind the scenes it is+encapsulated in a @SomeException@.+-}+data SomeException = forall e . Exception e => SomeException e+    deriving Typeable++instance Show SomeException where+    showsPrec p (SomeException e) = showsPrec p e++{- |+Any type that you wish to throw or catch as an exception must be an+instance of the @Exception@ class. The simplest case is a new exception+type directly below the root:++> data MyException = ThisException | ThatException+>     deriving (Show, Typeable)+>+> instance Exception MyException++The default method definitions in the @Exception@ class do what we need+in this case. You can now throw and catch @ThisException@ and+@ThatException@ as exceptions:++@+*Main> throw ThisException `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MyException))+Caught ThisException+@++In more complicated examples, you may wish to define a whole hierarchy+of exceptions:++> ---------------------------------------------------------------------+> -- Make the root exception type for all the exceptions in a compiler+>+> data SomeCompilerException = forall e . Exception e => SomeCompilerException e+>     deriving Typeable+>+> instance Show SomeCompilerException where+>     show (SomeCompilerException e) = show e+>+> instance Exception SomeCompilerException+>+> compilerExceptionToException :: Exception e => e -> SomeException+> compilerExceptionToException = toException . SomeCompilerException+>+> compilerExceptionFromException :: Exception e => SomeException -> Maybe e+> compilerExceptionFromException x = do+>     SomeCompilerException a <- fromException x+>     cast a+>+> ---------------------------------------------------------------------+> -- Make a subhierarchy for exceptions in the frontend of the compiler+>+> data SomeFrontendException = forall e . Exception e => SomeFrontendException e+>     deriving Typeable+>+> instance Show SomeFrontendException where+>     show (SomeFrontendException e) = show e+>+> instance Exception SomeFrontendException where+>     toException = compilerExceptionToException+>     fromException = compilerExceptionFromException+>+> frontendExceptionToException :: Exception e => e -> SomeException+> frontendExceptionToException = toException . SomeFrontendException+>+> frontendExceptionFromException :: Exception e => SomeException -> Maybe e+> frontendExceptionFromException x = do+>     SomeFrontendException a <- fromException x+>     cast a+>+> ---------------------------------------------------------------------+> -- Make an exception type for a particular frontend compiler exception+>+> data MismatchedParentheses = MismatchedParentheses+>     deriving (Typeable, Show)+>+> instance Exception MismatchedParentheses where+>     toException   = frontendExceptionToException+>     fromException = frontendExceptionFromException++We can now catch a @MismatchedParentheses@ exception as+@MismatchedParentheses@, @SomeFrontendException@ or+@SomeCompilerException@, but not other types, e.g. @IOException@:++@+*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses))+Caught MismatchedParentheses+*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException))+Caught MismatchedParentheses+*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException))+Caught MismatchedParentheses+*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: IOException))+*** Exception: MismatchedParentheses+@++-}+class (Typeable e, Show e) => Exception e where+    toException   :: e -> SomeException+    fromException :: SomeException -> Maybe e++    toException = SomeException+    fromException (SomeException e) = cast e++instance Exception SomeException where+    toException se = se+    fromException = Just+\end{code}++%*********************************************************+%*                                                      *+\subsection{Primitive throw}+%*                                                      *+%*********************************************************++\begin{code}+-- | Throw an exception.  Exceptions may be thrown from purely+-- functional code, but may only be caught within the 'IO' monad.+throw :: Exception e => e -> a+throw e = raise# (toException e)+\end{code}++\begin{code}+-- |This is thrown when the user calls 'error'. The @String@ is the+-- argument given to 'error'.+data ErrorCall = ErrorCall String+    deriving Typeable++instance Exception ErrorCall++instance Show ErrorCall where+    showsPrec _ (ErrorCall err) = showString err++-----++-- |Arithmetic exceptions.+data ArithException+  = Overflow+  | Underflow+  | LossOfPrecision+  | DivideByZero+  | Denormal+  deriving (Eq, Ord, Typeable)++instance Exception ArithException++instance Show ArithException where+  showsPrec _ Overflow        = showString "arithmetic overflow"+  showsPrec _ Underflow       = showString "arithmetic underflow"+  showsPrec _ LossOfPrecision = showString "loss of precision"+  showsPrec _ DivideByZero    = showString "divide by zero"+  showsPrec _ Denormal        = showString "denormal"++\end{code}
+ lib/base/src/GHC/Float.lhs view
@@ -0,0 +1,992 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Float+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The types 'Float' and 'Double', and the classes 'Floating' and 'RealFloat'.+--+-----------------------------------------------------------------------------++#include "ieee-flpt.h"++-- #hide+module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# )+    where++import Data.Maybe++import GHC.Base+import GHC.List+import GHC.Enum+import GHC.Show+import GHC.Num+import GHC.Real+import GHC.Arr++infixr 8  **+\end{code}++%*********************************************************+%*                                                      *+\subsection{Standard numeric classes}+%*                                                      *+%*********************************************************++\begin{code}+-- | Trigonometric and hyperbolic functions and related functions.+--+-- Minimal complete definition:+--      'pi', 'exp', 'log', 'sin', 'cos', 'sinh', 'cosh',+--      'asin', 'acos', 'atan', 'asinh', 'acosh' and 'atanh'+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++    x ** y              =  exp (log x * y)+    logBase x y         =  log y / log x+    sqrt x              =  x ** 0.5+    tan  x              =  sin  x / cos  x+    tanh x              =  sinh x / cosh x++-- | Efficient, machine-independent access to the components of a+-- floating-point number.+--+-- Minimal complete definition:+--      all except 'exponent', 'significand', 'scaleFloat' and 'atan2'+class  (RealFrac a, Floating a) => RealFloat a  where+    -- | a constant function, returning the radix of the representation+    -- (often @2@)+    floatRadix          :: a -> Integer+    -- | a constant function, returning the number of digits of+    -- 'floatRadix' in the significand+    floatDigits         :: a -> Int+    -- | a constant function, returning the lowest and highest values+    -- the exponent may assume+    floatRange          :: a -> (Int,Int)+    -- | The function 'decodeFloat' applied to a real floating-point+    -- number returns the significand expressed as an 'Integer' and an+    -- appropriately scaled exponent (an 'Int').  If @'decodeFloat' x@+    -- yields @(m,n)@, then @x@ is equal in value to @m*b^^n@, where @b@+    -- is the floating-point radix, and furthermore, either @m@ and @n@+    -- are both zero or else @b^(d-1) <= m < b^d@, where @d@ is the value+    -- of @'floatDigits' x@.  In particular, @'decodeFloat' 0 = (0,0)@.+    decodeFloat         :: a -> (Integer,Int)+    -- | 'encodeFloat' performs the inverse of 'decodeFloat'+    encodeFloat         :: Integer -> Int -> a+    -- | the second component of 'decodeFloat'.+    exponent            :: a -> Int+    -- | the first component of 'decodeFloat', scaled to lie in the open+    -- interval (@-1@,@1@)+    significand         :: a -> a+    -- | multiplies a floating-point number by an integer power of the radix+    scaleFloat          :: Int -> a -> a+    -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value+    isNaN               :: a -> Bool+    -- | 'True' if the argument is an IEEE infinity or negative infinity+    isInfinite          :: a -> Bool+    -- | 'True' if the argument is too small to be represented in+    -- normalized format+    isDenormalized      :: a -> Bool+    -- | 'True' if the argument is an IEEE negative zero+    isNegativeZero      :: a -> Bool+    -- | 'True' if the argument is an IEEE floating point number+    isIEEE              :: a -> Bool+    -- | a version of arctangent taking two real floating-point arguments.+    -- For real floating @x@ and @y@, @'atan2' y x@ computes the angle+    -- (from the positive x-axis) of the vector from the origin to the+    -- point @(x,y)@.  @'atan2' y x@ returns a value in the range [@-pi@,+    -- @pi@].  It follows the Common Lisp semantics for the origin when+    -- signed zeroes are supported.  @'atan2' y 1@, with @y@ in a type+    -- that is 'RealFloat', should return the same value as @'atan' y@.+    -- A default definition of 'atan2' is provided, but implementors+    -- can provide a more accurate implementation.+    atan2               :: a -> a -> a+++    exponent x          =  if m == 0 then 0 else n + floatDigits x+                           where (m,n) = decodeFloat x++    significand x       =  encodeFloat m (negate (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 +)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Float@}+%*                                                      *+%*********************************************************++\begin{code}+instance Eq Float where+    (F# x) == (F# y) = x `eqFloat#` y++instance Ord Float where+    (F# x) `compare` (F# y) | x `ltFloat#` y = LT+                            | x `eqFloat#` y = EQ+                            | otherwise      = GT++    (F# x) <  (F# y) = x `ltFloat#`  y+    (F# x) <= (F# y) = x `leFloat#`  y+    (F# x) >= (F# y) = x `geFloat#`  y+    (F# x) >  (F# y) = x `gtFloat#`  y++instance  Num Float  where+    (+)         x y     =  plusFloat x y+    (-)         x y     =  minusFloat x y+    negate      x       =  negateFloat x+    (*)         x y     =  timesFloat x y+    abs x | x >= 0.0    =  x+          | otherwise   =  negateFloat x+    signum x | x == 0.0  = 0+             | x > 0.0   = 1+             | otherwise = negate 1++    {-# INLINE fromInteger #-}+    fromInteger i = F# (floatFromInteger i)++instance  Real Float  where+    toRational x        =  (m%1)*(b%1)^^n+                           where (m,n) = decodeFloat x+                                 b     = floatRadix  x++instance  Fractional Float  where+    (/) x y             =  divideFloat x y+    fromRational x      =  fromRat x+    recip x             =  1.0 / x++{-# RULES "truncate/Float->Int" truncate = float2Int #-}+instance  RealFrac Float  where++    {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}+    {-# SPECIALIZE round    :: Float -> Int #-}++    {-# SPECIALIZE properFraction :: Float  -> (Integer, Float) #-}+    {-# SPECIALIZE round    :: Float -> Integer #-}++        -- ceiling, floor, and truncate are all small+    {-# INLINE ceiling #-}+    {-# INLINE floor #-}+    {-# INLINE truncate #-}++    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  = case properFraction x of+                     (n,_) -> n++    round x     = case properFraction x of+                     (n,r) -> let+                                m         = if r < 0.0 then n - 1 else n + 1+                                half_down = abs r - 0.5+                              in+                              case (compare half_down 0.0) of+                                LT -> n+                                EQ -> if even n then n else m+                                GT -> m++    ceiling x   = case properFraction x of+                    (n,r) -> if r > 0.0 then n + 1 else n++    floor x     = case properFraction x of+                    (n,r) -> if r < 0.0 then n - 1 else n++instance  Floating Float  where+    pi                  =  3.141592653589793238+    exp x               =  expFloat x+    log x               =  logFloat x+    sqrt x              =  sqrtFloat x+    sin x               =  sinFloat x+    cos x               =  cosFloat x+    tan x               =  tanFloat x+    asin x              =  asinFloat x+    acos x              =  acosFloat x+    atan x              =  atanFloat x+    sinh x              =  sinhFloat x+    cosh x              =  coshFloat x+    tanh x              =  tanhFloat x+    (**) x y            =  powerFloat x y+    logBase x y         =  log y / log x++    asinh x = log (x + sqrt (1.0+x*x))+    acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))+    atanh x = log ((x+1.0) / sqrt (1.0-x*x))++instance  RealFloat Float  where+    floatRadix _        =  FLT_RADIX        -- from float.h+    floatDigits _       =  FLT_MANT_DIG     -- ditto+    floatRange _        =  (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto++    decodeFloat (F# f#) = error "decodeFloat"{-case decodeFloatInteger f# of+                          (# i, e #) -> (i, I# e)-}++    encodeFloat i (I# e) = error "encodeFloat" --F# (encodeFloatInteger i e)++    exponent x          = case decodeFloat x of+                            (m,n) -> if m == 0 then 0 else n + floatDigits x++    significand x       = case decodeFloat x of+                            (m,_) -> encodeFloat m (negate (floatDigits x))++    scaleFloat k x      = case decodeFloat x of+                            (m,n) -> encodeFloat m (n+k)+    isNaN x          = 0 /= isFloatNaN x+    isInfinite x     = 0 /= isFloatInfinite x+    isDenormalized x = 0 /= isFloatDenormalized x+    isNegativeZero x = 0 /= isFloatNegativeZero x+    isIEEE _         = True++instance  Show Float  where+    showsPrec   x = showSignedFloat showFloat x+    showList = showList__ (showsPrec 0) +\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Double@}+%*                                                      *+%*********************************************************++\begin{code}+instance Eq Double where+    (D# x) == (D# y) = x ==## y++instance Ord Double where+    (D# x) `compare` (D# y) | x <## y   = LT+                            | x ==## y  = EQ+                            | otherwise = GT++    (D# x) <  (D# y) = x <##  y+    (D# x) <= (D# y) = x <=## y+    (D# x) >= (D# y) = x >=## y+    (D# x) >  (D# y) = x >##  y++instance  Num Double  where+    (+)         x y     =  plusDouble x y+    (-)         x y     =  minusDouble x y+    negate      x       =  negateDouble x+    (*)         x y     =  timesDouble x y+    abs x | x >= 0.0    =  x+          | otherwise   =  negateDouble x+    signum x | x == 0.0  = 0+             | x > 0.0   = 1+             | otherwise = negate 1++    {-# INLINE fromInteger #-}+    fromInteger i = D# (doubleFromInteger i)+++instance  Real Double  where+    toRational x        =  (m%1)*(b%1)^^n+                           where (m,n) = decodeFloat x+                                 b     = floatRadix  x++instance  Fractional Double  where+    (/) x y             =  divideDouble x y+    fromRational x      =  fromRat x+    recip x             =  1.0 / x++instance  Floating Double  where+    pi                  =  3.141592653589793238+    exp x               =  expDouble x+    log x               =  logDouble x+    sqrt x              =  sqrtDouble x+    sin  x              =  sinDouble x+    cos  x              =  cosDouble x+    tan  x              =  tanDouble x+    asin x              =  asinDouble x+    acos x              =  acosDouble x+    atan x              =  atanDouble x+    sinh x              =  sinhDouble x+    cosh x              =  coshDouble x+    tanh x              =  tanhDouble x+    (**) x y            =  powerDouble x y+    logBase x y         =  log y / log x++    asinh x = log (x + sqrt (1.0+x*x))+    acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))+    atanh x = log ((x+1.0) / sqrt (1.0-x*x))++{-# RULES "truncate/Double->Int" truncate = double2Int #-}+instance  RealFrac Double  where++    {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}+    {-# SPECIALIZE round    :: Double -> Int #-}++    {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}+    {-# SPECIALIZE round    :: Double -> Integer #-}++        -- ceiling, floor, and truncate are all small+    {-# INLINE ceiling #-}+    {-# INLINE floor #-}+    {-# INLINE truncate #-}++    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  = case properFraction x of+                     (n,_) -> n++    round x     = case properFraction x of+                     (n,r) -> let+                                m         = if r < 0.0 then n - 1 else n + 1+                                half_down = abs r - 0.5+                              in+                              case (compare half_down 0.0) of+                                LT -> n+                                EQ -> if even n then n else m+                                GT -> m++    ceiling x   = case properFraction x of+                    (n,r) -> if r > 0.0 then n + 1 else n++    floor x     = case properFraction x of+                    (n,r) -> if r < 0.0 then n - 1 else n++instance  RealFloat Double  where+    floatRadix _        =  FLT_RADIX        -- from float.h+    floatDigits _       =  DBL_MANT_DIG     -- ditto+    floatRange _        =  (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto++    decodeFloat (D# x#)+      = error "decodeFloat" {-case decodeDoubleInteger x#   of+          (# i, j #) -> (i, I# j)-}++    encodeFloat i (I# j) = error "encodeFloat" {-D# (encodeDoubleInteger i j)-}++    exponent x          = case decodeFloat x of+                            (m,n) -> if m == 0 then 0 else n + floatDigits x++    significand x       = case decodeFloat x of+                            (m,_) -> encodeFloat m (negate (floatDigits x))++    scaleFloat k x      = case decodeFloat x of+                            (m,n) -> encodeFloat m (n+k)++    isNaN x             = 0 /= isDoubleNaN x+    isInfinite x        = 0 /= isDoubleInfinite x+    isDenormalized x    = 0 /= isDoubleDenormalized x+    isNegativeZero x    = 0 /= isDoubleNegativeZero x+    isIEEE _            = True++instance  Show Double  where+    showsPrec   x = showSignedFloat showFloat x+    showList = showList__ (showsPrec 0) +\end{code}++%*********************************************************+%*                                                      *+\subsection{@Enum@ instances}+%*                                                      *+%*********************************************************++The @Enum@ instances for Floats and Doubles are slightly unusual.+The @toEnum@ function truncates numbers to Int.  The definitions+of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic+series: [0,0.1 .. 1.0].  However, roundoff errors make these somewhat+dubious.  This example may have either 10 or 11 elements, depending on+how 0.1 is represented.++NOTE: The instances for Float and Double do not make use of the default+methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being+a `non-lossy' conversion to and from Ints. Instead we make use of the +1.2 default methods (back in the days when Enum had Ord as a superclass)+for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.)++\begin{code}+instance  Enum Float  where+    succ x         = x + 1+    pred x         = x - 1+    toEnum         = int2Float+    fromEnum       = fromInteger . truncate   -- may overflow+    enumFrom       = numericEnumFrom+    enumFromTo     = numericEnumFromTo+    enumFromThen   = numericEnumFromThen+    enumFromThenTo = numericEnumFromThenTo++instance  Enum Double  where+    succ x         = x + 1+    pred x         = x - 1+    toEnum         =  int2Double+    fromEnum       =  fromInteger . truncate   -- may overflow+    enumFrom       =  numericEnumFrom+    enumFromTo     =  numericEnumFromTo+    enumFromThen   =  numericEnumFromThen+    enumFromThenTo =  numericEnumFromThenTo+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Printing floating point}+%*                                                      *+%*********************************************************+++\begin{code}+-- | Show a signed 'RealFloat' value to full precision+-- using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise.+showFloat :: (RealFloat a) => a -> ShowS+showFloat x  =  showString (formatRealFloat FFGeneric Nothing x)++-- 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+   | isNaN x                   = "NaN"+   | isInfinite x              = if x < 0 then "-Infinity" else "Infinity"+   | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x))+   | otherwise                 = doFmt fmt (floatToDigits (toInteger base) x)+ where +  base = 10++  doFmt format (is, e) =+    let ds = map intToDigit is in+    case format of+     FFGeneric ->+      doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)+            (is,e)+     FFExponent ->+      case decs of+       Nothing ->+        let show_e' = show (e-1) in+        case ds of+          "0"     -> "0.0e0"+          [d]     -> d : ".0e" ++ show_e'+          (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'+          []      -> error "formatRealFloat/doFmt/FFExponent: []"+       Just dec ->+        let dec' = max dec 1 in+        case is of+         [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0"+         _ ->+          let+           (ei,is') = roundTo base (dec'+1) is+           (d:ds') = map intToDigit (if ei > 0 then init is' else is')+          in+          d:'.':ds' ++ 'e':show (e-1+ei)+     FFFixed ->+      let+       mk0 ls = case ls of { "" -> "0" ; _ -> ls}+      in+      case decs of+       Nothing+          | e <= 0    -> "0." ++ replicate (-e) '0' ++ ds+          | otherwise ->+             let+                f 0 s    rs  = mk0 (reverse s) ++ '.':mk0 rs+                f n s    ""  = f (n-1) ('0':s) ""+                f n s (r:rs) = f (n-1) (r:s) rs+             in+                f e "" ds+       Just dec ->+        let dec' = max dec 0 in+        if e >= 0 then+         let+          (ei,is') = roundTo base (dec' + e) is+          (ls,rs)  = splitAt (e+ei) (map intToDigit is')+         in+         mk0 ls ++ (if null rs then "" else '.':rs)+        else+         let+          (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)+          d:ds' = map intToDigit (if ei > 0 then is' else 0:is')+         in+         d : (if null ds' then "" else '.':ds')+++roundTo :: Int -> Int -> [Int] -> (Int,[Int])+roundTo base d is =+  case f d is of+    x@(0,_) -> x+    (1,xs)  -> (1, 1:xs)+    _       -> error "roundTo: bad Value"+ where+  b2 = base `div` 2++  f n []     = (0, replicate n 0)+  f 0 (x:_)  = (if x >= b2 then 1 else 0, [])+  f n (i:xs)+     | i' == base = (1,0:ds)+     | otherwise  = (0,i':ds)+      where+       (c,ds) = f (n-1) xs+       i'     = c + i++-- Based on "Printing Floating-Point Numbers Quickly and Accurately"+-- by R.G. Burger and R.K. Dybvig in PLDI 96.+-- This version uses a much slower logarithm estimator. It should be improved.++-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,+-- and returns a list of digits and an exponent. +-- In particular, if @x>=0@, and+--+-- > floatToDigits base x = ([d1,d2,...,dn], e)+--+-- then+--+--      (1) @n >= 1@+--+--      (2) @x = 0.d1d2...dn * (base**e)@+--+--      (3) @0 <= di <= base-1@++floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)+floatToDigits _ 0 = ([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, 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 :: Int+  k =+   let +    k0 :: Int+    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)) ++                 fromIntegral e * log (fromInteger b)) /+                   log (fromInteger base))+--WAS:            fromInt e * log (fromInteger b))++    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++  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)++\end{code}+++%*********************************************************+%*                                                      *+\subsection{Converting from a Rational to a RealFloat+%*                                                      *+%*********************************************************++[In response to a request for documentation of how fromRational works,+Joe Fasel writes:] A quite reasonable request!  This code was added to+the Prelude just before the 1.2 release, when Lennart, working with an+early version of hbi, noticed that (read . show) was not the identity+for floating-point numbers.  (There was a one-bit error about half the+time.)  The original version of the conversion function was in fact+simply a floating-point divide, as you suggest above. The new version+is, I grant you, somewhat denser.++Unfortunately, Joe's code doesn't work!  Here's an example:++main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")++This program prints+        0.0000000000000000+instead of+        1.8217369128763981e-300++Here's Joe's code:++\begin{pseudocode}+fromRat :: (RealFloat a) => Rational -> a+fromRat x = x'+        where x' = f e++--              If the exponent of the nearest floating-point number to x +--              is e, then the significand is the integer nearest xb^(-e),+--              where b is the floating-point radix.  We start with a good+--              guess for e, and if it is correct, the exponent of the+--              floating-point number we construct will again be e.  If+--              not, one more iteration is needed.++              f e   = if e' == e then y else f e'+                      where y      = encodeFloat (round (x * (1 % b)^^e)) e+                            (_,e') = decodeFloat y+              b     = floatRadix x'++--              We obtain a trial exponent by doing a floating-point+--              division of x's numerator by its denominator.  The+--              result of this division may not itself be the ultimate+--              result, because of an accumulation of three rounding+--              errors.++              (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'+                                        / fromInteger (denominator x))+\end{pseudocode}++Now, here's Lennart's code (which works)++\begin{code}+-- | Converts a 'Rational' value into any type in class 'RealFloat'.+{-# SPECIALISE fromRat :: Rational -> Double,+                          Rational -> Float #-}+fromRat :: (RealFloat a) => Rational -> a++-- Deal with special cases first, delegating the real work to fromRat'+fromRat (n :% 0) | n > 0     =  1/0        -- +Infinity+                 | n < 0     = -1/0        -- -Infinity+                 | otherwise =  0/0        -- NaN++fromRat (n :% d) | n > 0     = fromRat' (n :% d)+                 | n < 0     = - fromRat' ((-n) :% d)+                 | otherwise = encodeFloat 0 0             -- Zero++-- 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+-- Invariant: argument is strictly positive+fromRat' 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'++-- 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 + | p <= minExp = (x, p)+ | x >= xMax   = scaleRat b minExp xMin xMax (p+1) (x/b)+ | x < xMin    = scaleRat b minExp xMin xMax (p-1) (x*b)+ | otherwise   = (x, p)++-- Exponentiation with a cache for the most common numbers.+minExpt, maxExpt :: Int+minExpt = 0+maxExpt = 1100++expt :: Integer -> Int -> Integer+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+   | i < b     = 0+   | otherwise = doDiv (i `div` (b^l)) l+       where+        -- Try squaring the base first to cut down the number of divisions.+         l = 2 * integerLogBase (b*b) i++         doDiv :: Integer -> Int -> Int+         doDiv x y+            | x < b     = y+            | otherwise = doDiv (x `div` b) (y+1)++\end{code}+++%*********************************************************+%*                                                      *+\subsection{Floating point numeric primops}+%*                                                      *+%*********************************************************++Definitions of the boxed PrimOps; these will be+used in the case of partial applications, etc.++\begin{code}+plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float+plusFloat   (F# x) (F# y) = F# (plusFloat# x y)+minusFloat  (F# x) (F# y) = F# (minusFloat# x y)+timesFloat  (F# x) (F# y) = F# (timesFloat# x y)+divideFloat (F# x) (F# y) = F# (divideFloat# x y)++negateFloat :: Float -> Float+negateFloat (F# x)        = F# (negateFloat# x)++gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool+gtFloat     (F# x) (F# y) = gtFloat# x y+geFloat     (F# x) (F# y) = geFloat# x y+eqFloat     (F# x) (F# y) = eqFloat# x y+neFloat     (F# x) (F# y) = neFloat# x y+ltFloat     (F# x) (F# y) = ltFloat# x y+leFloat     (F# x) (F# y) = leFloat# x y++float2Int :: Float -> Int+float2Int   (F# x) = I# (float2Int# x)++int2Float :: Int -> Float+int2Float   (I# x) = F# (int2Float# x)++expFloat, logFloat, sqrtFloat :: Float -> Float+sinFloat, cosFloat, tanFloat  :: Float -> Float+asinFloat, acosFloat, atanFloat  :: Float -> Float+sinhFloat, coshFloat, tanhFloat  :: Float -> Float+expFloat    (F# x) = F# (expFloat# x)+logFloat    (F# x) = F# (logFloat# x)+sqrtFloat   (F# x) = F# (sqrtFloat# x)+sinFloat    (F# x) = F# (sinFloat# x)+cosFloat    (F# x) = F# (cosFloat# x)+tanFloat    (F# x) = F# (tanFloat# x)+asinFloat   (F# x) = F# (asinFloat# x)+acosFloat   (F# x) = F# (acosFloat# x)+atanFloat   (F# x) = F# (atanFloat# x)+sinhFloat   (F# x) = F# (sinhFloat# x)+coshFloat   (F# x) = F# (coshFloat# x)+tanhFloat   (F# x) = F# (tanhFloat# x)++powerFloat :: Float -> Float -> Float+powerFloat  (F# x) (F# y) = F# (powerFloat# x y)++-- definitions of the boxed PrimOps; these will be+-- used in the case of partial applications, etc.++plusDouble, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double+plusDouble   (D# x) (D# y) = D# (x +## y)+minusDouble  (D# x) (D# y) = D# (x -## y)+timesDouble  (D# x) (D# y) = D# (x *## y)+divideDouble (D# x) (D# y) = D# (x /## y)++negateDouble :: Double -> Double+negateDouble (D# x)        = D# (negateDouble# x)++gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool+gtDouble    (D# x) (D# y) = x >## y+geDouble    (D# x) (D# y) = x >=## y+eqDouble    (D# x) (D# y) = x ==## y+neDouble    (D# x) (D# y) = x /=## y+ltDouble    (D# x) (D# y) = x <## y+leDouble    (D# x) (D# y) = x <=## y++double2Int :: Double -> Int+double2Int   (D# x) = I# (double2Int#   x)++int2Double :: Int -> Double+int2Double   (I# x) = D# (int2Double#   x)++double2Float :: Double -> Float+double2Float (D# x) = F# (double2Float# x)++float2Double :: Float -> Double+float2Double (F# x) = D# (float2Double# x)++expDouble, logDouble, sqrtDouble :: Double -> Double+sinDouble, cosDouble, tanDouble  :: Double -> Double+asinDouble, acosDouble, atanDouble  :: Double -> Double+sinhDouble, coshDouble, tanhDouble  :: Double -> Double+expDouble    (D# x) = D# (expDouble# x)+logDouble    (D# x) = D# (logDouble# x)+sqrtDouble   (D# x) = D# (sqrtDouble# x)+sinDouble    (D# x) = D# (sinDouble# x)+cosDouble    (D# x) = D# (cosDouble# x)+tanDouble    (D# x) = D# (tanDouble# x)+asinDouble   (D# x) = D# (asinDouble# x)+acosDouble   (D# x) = D# (acosDouble# x)+atanDouble   (D# x) = D# (atanDouble# x)+sinhDouble   (D# x) = D# (sinhDouble# x)+coshDouble   (D# x) = D# (coshDouble# x)+tanhDouble   (D# x) = D# (tanhDouble# x)++powerDouble :: Double -> Double -> Double+powerDouble  (D# x) (D# y) = D# (x **## y)+\end{code}++\begin{code}+foreign import ccall unsafe "__encodeFloat"+        encodeFloat# :: Int# -> ByteArray# -> Int -> Float+foreign import ccall unsafe "__int_encodeFloat"+        int_encodeFloat# :: Int# -> Int -> Float+++foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int+foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int+foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int+foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int+++foreign import ccall unsafe "__encodeDouble"+        encodeDouble# :: Int# -> ByteArray# -> Int -> Double++foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int+foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int+foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int+foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int+\end{code}++%*********************************************************+%*                                                      *+\subsection{Coercion rules}+%*                                                      *+%*********************************************************++\begin{code}+{-# RULES+"fromIntegral/Int->Float"   fromIntegral = int2Float+"fromIntegral/Int->Double"  fromIntegral = int2Double+"realToFrac/Float->Float"   realToFrac   = id :: Float -> Float+"realToFrac/Float->Double"  realToFrac   = float2Double+"realToFrac/Double->Float"  realToFrac   = double2Float+"realToFrac/Double->Double" realToFrac   = id :: Double -> Double+"realToFrac/Int->Double"    realToFrac   = int2Double	-- See Note [realToFrac int-to-float]+"realToFrac/Int->Float"     realToFrac   = int2Float	-- 	..ditto+    #-}+\end{code}++Note [realToFrac int-to-float]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don found that the RULES for realToFrac/Int->Double and simliarly+Float made a huge difference to some stream-fusion programs.  Here's+an example+  +      import Data.Array.Vector+  +      n = 40000000+  +      main = do+            let c = replicateU n (2::Double)+                a = mapU realToFrac (enumFromToU 0 (n-1) ) :: UArr Double+            print (sumU (zipWithU (*) c a))+  +Without the RULE we get this loop body:+  +      case $wtoRational sc_sY4 of ww_aM7 { (# ww1_aM9, ww2_aMa #) ->+      case $wfromRat ww1_aM9 ww2_aMa of tpl_X1P { D# ipv_sW3 ->+      Main.$s$wfold+        (+# sc_sY4 1)+        (+# wild_X1i 1)+        (+## sc2_sY6 (*## 2.0 ipv_sW3))+  +And with the rule:+  +     Main.$s$wfold+        (+# sc_sXT 1)+        (+# wild_X1h 1)+        (+## sc2_sXV (*## 2.0 (int2Double# sc_sXT)))+  +The running time of the program goes from 120 seconds to 0.198 seconds+with the native backend, and 0.143 seconds with the C backend.+  +A few more details in Trac #2251, and the patch message +"Add RULES for realToFrac from Int".++%*********************************************************+%*                                                      *+\subsection{Utils}+%*                                                      *+%*********************************************************++\begin{code}+showSignedFloat :: (RealFloat a)+  => (a -> ShowS)       -- ^ a function that can show unsigned values+  -> Int                -- ^ the precedence of the enclosing context+  -> a                  -- ^ the value to show+  -> ShowS+showSignedFloat showPos p x+   | x < 0 || isNegativeZero x+       = showParen (p > 6) (showChar '-' . showPos (-x))+   | otherwise = showPos x+\end{code}
+ lib/base/src/GHC/ForeignPtr.hs view
@@ -0,0 +1,373 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.ForeignPtr+-- Copyright   :  (c) The University of Glasgow, 1992-2003+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC's implementation of the 'ForeignPtr' data type.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.ForeignPtr+  (+        ForeignPtr(..),+        FinalizerPtr,+        FinalizerEnvPtr,+        newForeignPtr_,+        mallocForeignPtr,+        mallocPlainForeignPtr,+        mallocForeignPtrBytes,+        mallocPlainForeignPtrBytes,+        addForeignPtrFinalizer,+        addForeignPtrFinalizerEnv,+        touchForeignPtr,+        unsafeForeignPtrToPtr,+        castForeignPtr,+        newConcForeignPtr,+        addForeignPtrConcFinalizer,+        finalizeForeignPtr+  ) where++import Control.Monad    ( sequence_ )+import Foreign.Storable+--import Data.Typeable++import GHC.Show+import GHC.List         ( null )+import GHC.Base+import GHC.IOBase+import GHC.STRef        ( STRef(..) )+import GHC.Ptr          ( Ptr(..), FunPtr(..) )+import GHC.Err+++-- |The type 'ForeignPtr' represents references to objects that are+-- maintained in a foreign language, i.e., that are not part of the+-- data structures usually managed by the Haskell storage manager.+-- The essential difference between 'ForeignPtr's and vanilla memory+-- references of type @Ptr a@ is that the former may be associated+-- with /finalizers/. A finalizer is a routine that is invoked when+-- the Haskell storage manager detects that - within the Haskell heap+-- and stack - there are no more references left that are pointing to+-- the 'ForeignPtr'.  Typically, the finalizer will, then, invoke+-- routines in the foreign language that free the resources bound by+-- the foreign object.+--+-- The 'ForeignPtr' is parameterised in the same way as 'Ptr'.  The+-- type argument of 'ForeignPtr' should normally be an instance of+-- class 'Storable'.+--+data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents+        -- we cache the Addr# in the ForeignPtr object, but attach+        -- the finalizer to the IORef (or the MutableByteArray# in+        -- the case of a MallocPtr).  The aim of the representation+        -- is to make withForeignPtr efficient; in fact, withForeignPtr+        -- should be just as efficient as unpacking a Ptr, and multiple+        -- withForeignPtrs can share an unpacked ForeignPtr.  Note+        -- that touchForeignPtr only has to touch the ForeignPtrContents+        -- object, because that ensures that whatever the finalizer is+        -- attached to is kept alive.++{-INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")-}++data Finalizers+  = NoFinalizers+  | CFinalizers+  | HaskellFinalizers+    deriving Eq++data ForeignPtrContents+  = PlainForeignPtr !(IORef (Finalizers, [IO ()]))+  | MallocPtr      (MutableByteArray# RealWorld) !(IORef (Finalizers, [IO ()]))+  | PlainPtr       (MutableByteArray# RealWorld)++instance Eq (ForeignPtr a) where+    p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q++instance Ord (ForeignPtr a) where+    compare p q  =  compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)++instance Show (ForeignPtr a) where+    showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)+++-- |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 FinalizerPtr a        = FunPtr (Ptr a -> IO ())+type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())++newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)+--+-- ^Turns a plain memory reference into a foreign object by+-- associating a finalizer - given by the monadic operation - with the+-- reference.  The storage manager will start the finalizer, in a+-- separate thread, some time after the last reference to the+-- @ForeignPtr@ is dropped.  There is no guarantee of promptness, and+-- in fact there is no guarantee that the finalizer will eventually+-- run at all.+--+-- Note that references from a finalizer do not necessarily prevent+-- another object from being finalized.  If A's finalizer refers to B+-- (perhaps using 'touchForeignPtr', then the only guarantee is that+-- B's finalizer will never be started before A's.  If both A and B+-- are unreachable, then both finalizers will start together.  See+-- 'touchForeignPtr' for more on finalizer ordering.+--+newConcForeignPtr p finalizer+  = do fObj <- newForeignPtr_ p+       addForeignPtrConcFinalizer fObj finalizer+       return fObj++mallocForeignPtr :: Storable a => IO (ForeignPtr a)+-- ^ Allocate some memory and return a 'ForeignPtr' to it.  The memory+-- will be released automatically when the 'ForeignPtr' is discarded.+--+-- 'mallocForeignPtr' is equivalent to+--+-- >    do { p <- malloc; newForeignPtr finalizerFree p }+-- +-- although it may be implemented differently internally: you may not+-- assume that the memory returned by 'mallocForeignPtr' has been+-- allocated with 'Foreign.Marshal.Alloc.malloc'.+--+-- GHC notes: 'mallocForeignPtr' has a heavily optimised+-- implementation in GHC.  It uses pinned memory in the garbage+-- collected heap, so the 'ForeignPtr' does not require a finalizer to+-- free the memory.  Use of 'mallocForeignPtr' and associated+-- functions is strongly recommended in preference to 'newForeignPtr'+-- with a finalizer.+-- +mallocForeignPtr = doMalloc undefined+  where doMalloc :: Storable b => b -> IO (ForeignPtr b)+        doMalloc a = do+          r <- newIORef (NoFinalizers, [])+          IO $ \s ->+            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->+             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                               (MallocPtr mbarr# r) #)+            }+            where (I# size)  = sizeOf a+                  (I# align) = alignment a++-- | This function is similar to 'mallocForeignPtr', except that the+-- size of the memory required is given explicitly as a number of bytes.+mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes (I# size) = do +  r <- newIORef (NoFinalizers, [])+  IO $ \s ->+     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                         (MallocPtr mbarr# r) #)+     }++-- | Allocate some memory and return a 'ForeignPtr' to it.  The memory+-- will be released automatically when the 'ForeignPtr' is discarded.+--+-- GHC notes: 'mallocPlainForeignPtr' has a heavily optimised+-- implementation in GHC.  It uses pinned memory in the garbage+-- collected heap, as for mallocForeignPtr. Unlike mallocForeignPtr, a+-- ForeignPtr created with mallocPlainForeignPtr carries no finalizers.+-- It is not possible to add a finalizer to a ForeignPtr created with+-- mallocPlainForeignPtr. This is useful for ForeignPtrs that will live+-- only inside Haskell (such as those created for packed strings).+-- Attempts to add a finalizer to a ForeignPtr created this way, or to+-- finalize such a pointer, will throw an exception.+-- +mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)+mallocPlainForeignPtr = doMalloc undefined+  where doMalloc :: Storable b => b -> IO (ForeignPtr b)+        doMalloc a = IO $ \s ->+            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->+             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                               (PlainPtr mbarr#) #)+            }+            where (I# size)  = sizeOf a+                  (I# align) = alignment a++-- | This function is similar to 'mallocForeignPtrBytes', except that+-- the internally an optimised ForeignPtr representation with no+-- finalizer is used. Attempts to add a finalizer will cause an+-- exception to be thrown.+mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocPlainForeignPtrBytes (I# size) = IO $ \s ->+    case newPinnedByteArray# size s      of { (# s', mbarr# #) ->+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                         (PlainPtr mbarr#) #)+     }++addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()+-- ^This function adds a finalizer to the given foreign object.  The+-- finalizer will run /before/ all other finalizers for the same+-- object which have already been registered.+addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of+  PlainForeignPtr r -> f r >> return ()+  MallocPtr     _ r -> f r >> return ()+  _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"+  where+    f r =+      noMixing CFinalizers r $+        IO $ \s ->+          case r of { IORef (STRef r#) ->+          case mkWeakForeignEnv# r# () fp p 0# nullAddr# s of { (# s1, w #) ->+          (# s1, finalizeForeign w #) }}++addForeignPtrFinalizerEnv ::+  FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()+-- ^ 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 (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of+  PlainForeignPtr r -> f r >> return ()+  MallocPtr     _ r -> f r >> return ()+  _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"+  where+    f r =+      noMixing CFinalizers r $+        IO $ \s ->+          case r of { IORef (STRef r#) ->+          case mkWeakForeignEnv# r# () fp p 1# ep s of { (# s1, w #) ->+          (# s1, finalizeForeign w #) }}++finalizeForeign :: Weak# () -> IO ()+finalizeForeign w = IO $ \s ->+  case finalizeWeak# w s of+    (# s1, 0#, _ #) -> (# s1, () #)+    (# s1, _ , f #) -> f s1++addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()+-- ^This function adds a finalizer to the given @ForeignPtr@.  The+-- finalizer will run /before/ all other finalizers for the same+-- object which have already been registered.+--+-- This is a variant of @addForeignPtrFinalizer@, where the finalizer+-- is an arbitrary @IO@ action.  When it is invoked, the finalizer+-- will run in a new thread.+--+-- NB. Be very careful with these finalizers.  One common trap is that+-- if a finalizer references another finalized value, it does not+-- prevent that value from being finalized.  In particular, 'Handle's+-- are finalized objects, so a finalizer should not refer to a 'Handle'+-- (including @stdout@, @stdin@ or @stderr@).+--+addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = +  addForeignPtrConcFinalizer_ c finalizer++addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO ()+addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do+  noFinalizers <- noMixing HaskellFinalizers r (return finalizer)+  if noFinalizers+     then IO $ \s ->+              case r of { IORef (STRef r#) ->+              case mkWeak# r# () (foreignPtrFinalizer r) s of {  (# s1, _ #) ->+              (# s1, () #) }}+     else return ()+addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do+  noFinalizers <- noMixing HaskellFinalizers r (return finalizer)+  if noFinalizers+     then  IO $ \s -> +               case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of+                  (# s1, _ #) -> (# s1, () #)+     else return ()++addForeignPtrConcFinalizer_ _ _ =+  error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"++noMixing ::+  Finalizers -> IORef (Finalizers, [IO ()]) -> IO (IO ()) -> IO Bool+noMixing ftype0 r mkF = do+  (ftype, fs) <- readIORef r+  if ftype /= NoFinalizers && ftype /= ftype0+     then error ("GHC.ForeignPtr: attempt to mix Haskell and C finalizers " +++                 "in the same ForeignPtr")+     else do+       f <- mkF+       writeIORef r (ftype0, f : fs)+       return (null fs)++foreignPtrFinalizer :: IORef (Finalizers, [IO ()]) -> IO ()+foreignPtrFinalizer r = do (_, fs) <- readIORef r; sequence_ fs++newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)+-- ^Turns a plain memory reference into a foreign pointer that may be+-- associated with finalizers by using 'addForeignPtrFinalizer'.+newForeignPtr_ (Ptr obj) =  do+  r <- newIORef (NoFinalizers, [])+  return (ForeignPtr obj (PlainForeignPtr r))++touchForeignPtr :: ForeignPtr a -> IO ()+-- ^This function ensures that the foreign object in+-- question is alive at the given place in the sequence of IO+-- actions. In particular 'Foreign.ForeignPtr.withForeignPtr'+-- does a 'touchForeignPtr' after it+-- executes the user action.+-- +-- Note that this function should not be used to express dependencies+-- between finalizers on 'ForeignPtr's.  For example, if the finalizer+-- for a 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second+-- 'ForeignPtr' @F2@, then the only guarantee is that the finalizer+-- for @F2@ is never started before the finalizer for @F1@.  They+-- might be started together if for example both @F1@ and @F2@ are+-- otherwise unreachable, and in that case the scheduler might end up+-- running the finalizer for @F2@ first.+--+-- In general, it is not recommended to use finalizers on separate+-- objects with ordering constraints between them.  To express the+-- ordering robustly requires explicit synchronisation using @MVar@s+-- between the finalizers, but even then the runtime sometimes runs+-- multiple finalizers sequentially in a single thread (for+-- performance reasons), so synchronisation between finalizers could+-- result in artificial deadlock.  Another alternative is to use+-- explicit reference counting.+--+touchForeignPtr (ForeignPtr _ r) = touch r++touch :: ForeignPtrContents -> IO ()+touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)++unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a+-- ^This function extracts the pointer component of a foreign+-- pointer.  This is a potentially dangerous operations, as if the+-- argument to 'unsafeForeignPtrToPtr' is the last usage+-- occurrence of the given foreign pointer, then its finalizer(s) will+-- be run, which potentially invalidates the plain pointer just+-- obtained.  Hence, 'touchForeignPtr' must be used+-- wherever it has to be guaranteed that the pointer lives on - i.e.,+-- has another usage occurrence.+--+-- To avoid subtle coding errors, hand written marshalling code+-- should preferably use 'Foreign.ForeignPtr.withForeignPtr' rather+-- than combinations of 'unsafeForeignPtrToPtr' and+-- 'touchForeignPtr'.  However, the later routines+-- are occasionally preferred in tool generated marshalling code.+unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo++castForeignPtr :: ForeignPtr a -> ForeignPtr b+-- ^This function casts a 'ForeignPtr'+-- parameterised by one type into another type.+castForeignPtr f = unsafeCoerce# f++-- | Causes the finalizers associated with a foreign pointer to be run+-- immediately.+finalizeForeignPtr :: ForeignPtr a -> IO ()+finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect+finalizeForeignPtr (ForeignPtr _ foreignPtr) = do+        (ftype, finalizers) <- readIORef refFinalizers+        sequence_ finalizers+        writeIORef refFinalizers (ftype, [])+        where+                refFinalizers = case foreignPtr of+                        (PlainForeignPtr ref) -> ref+                        (MallocPtr     _ ref) -> ref+                        PlainPtr _            ->+                            error "finalizeForeignPtr PlainPtr"+
+ lib/base/src/GHC/Handle.hs view
@@ -0,0 +1,1843 @@+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_HADDOCK hide #-}++#undef DEBUG_DUMP+#undef DEBUG++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Handle+-- Copyright   :  (c) The University of Glasgow, 1994-2001+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- This module defines the basic operations on I\/O \"handles\".+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Handle (+  withHandle, withHandle', withHandle_,+  wantWritableHandle, wantReadableHandle, wantSeekableHandle,++  newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,+  flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,+  fillReadBuffer, fillReadBufferWithoutBlocking,+  readRawBuffer, readRawBufferPtr,+  readRawBufferNoBlock, readRawBufferPtrNoBlock,+  writeRawBuffer, writeRawBufferPtr,++#ifndef mingw32_HOST_OS+  unlockFile,+#endif++  ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,++  stdin, stdout, stderr,+  IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',+  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode,+  hFlush, hDuplicate, hDuplicateTo,++  hClose, hClose_help,++  HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,+  SeekMode(..), hSeek, hTell,++  hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,+  hSetEcho, hGetEcho, hIsTerminalDevice,++  hShow,++#ifdef DEBUG_DUMP+  puts,+#endif++ ) where++import Control.Monad+import Data.Maybe+import Foreign+import Foreign.C+import System.IO.Error+import System.Posix.Internals+import System.Posix.Types++import GHC.Real++import GHC.Arr+import GHC.Base+import GHC.Read         ( Read )+import GHC.List+import GHC.IOBase+import GHC.Exception+import GHC.Enum+import GHC.Num          ( Integer, Num(..) )+import GHC.Show+#if defined(DEBUG_DUMP)+import GHC.Pack+#endif++import GHC.Conc++-- -----------------------------------------------------------------------------+-- TODO:++-- hWaitForInput blocks (should use a timeout)++-- unbuffered hGetLine is a bit dodgy++-- hSetBuffering: can't change buffering on a stream, +--      when the read buffer is non-empty? (no way to flush the buffer)++-- ---------------------------------------------------------------------------+-- Are files opened by default in text or binary mode, if the user doesn't+-- specify?++dEFAULT_OPEN_IN_BINARY_MODE :: Bool+dEFAULT_OPEN_IN_BINARY_MODE = False++-- ---------------------------------------------------------------------------+-- Creating a new handle++newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle+newFileHandle filepath finalizer hc = do+  m <- newMVar hc+  addMVarFinalizer m (finalizer m)+  return (FileHandle filepath m)++-- ---------------------------------------------------------------------------+-- Working with Handles++{-+In the concurrent world, handles are locked during use.  This is done+by wrapping an MVar around the handle which acts as a mutex over+operations on the handle.++To avoid races, we use the following bracketing operations.  The idea+is to obtain the lock, do some operation and replace the lock again,+whether the operation succeeded or failed.  We also want to handle the+case where the thread receives an exception while processing the IO+operation: in these cases we also want to relinquish the lock.++There are three versions of @withHandle@: corresponding to the three+possible combinations of:++        - the operation may side-effect the handle+        - the operation may return a result++If the operation generates an error or an exception is raised, the+original handle is always replaced [ this is the case at the moment,+but we might want to revisit this in the future --SDM ].+-}++{-# INLINE withHandle #-}+withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a+withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act+withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act++withHandle' :: String -> Handle -> MVar Handle__+   -> (Handle__ -> IO (Handle__,a)) -> IO a+withHandle' fun h m act =+   block $ do+   h_ <- takeMVar m+   checkBufferInvariants h_+   (h',v)  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)+              `catchException` \ex -> ioError (augmentIOError ex fun h)+   checkBufferInvariants h'+   putMVar m h'+   return v++{-# INLINE withHandle_ #-}+withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a+withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act+withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act++withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a+withHandle_' fun h m act =+   block $ do+   h_ <- takeMVar m+   checkBufferInvariants h_+   v  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)+         `catchException` \ex -> ioError (augmentIOError ex fun h)+   checkBufferInvariants h_+   putMVar m h_+   return v++withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()+withAllHandles__ fun h@(FileHandle _ m)     act = withHandle__' fun h m act+withAllHandles__ fun h@(DuplexHandle _ r w) act = do+  withHandle__' fun h r act+  withHandle__' fun h w act++withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)+              -> IO ()+withHandle__' fun h m act =+   block $ do+   h_ <- takeMVar m+   checkBufferInvariants h_+   h'  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)+          `catchException` \ex -> ioError (augmentIOError ex fun h)+   checkBufferInvariants h'+   putMVar m h'+   return ()++augmentIOError :: IOException -> String -> Handle -> IOException+augmentIOError (IOError _ iot _ str fp) fun h+  = IOError (Just h) iot fun str filepath+  where filepath+          | Just _ <- fp = fp+          | otherwise = case h of+                          FileHandle path _     -> Just path+                          DuplexHandle path _ _ -> Just path++-- ---------------------------------------------------------------------------+-- Wrapper for write operations.++wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a+wantWritableHandle fun h@(FileHandle _ m) act+  = wantWritableHandle' fun h m act+wantWritableHandle fun h@(DuplexHandle _ _ m) act+  = wantWritableHandle' fun h m act+  -- ToDo: in the Duplex case, we don't need to checkWritableHandle++wantWritableHandle'+        :: String -> Handle -> MVar Handle__+        -> (Handle__ -> IO a) -> IO a+wantWritableHandle' fun h m act+   = withHandle_' fun h m (checkWritableHandle act)++checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a+checkWritableHandle act handle_+  = case haType handle_ of+      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      ReadHandle           -> ioe_notWritable+      ReadWriteHandle      -> do+                let ref = haBuffer handle_+                buf <- readIORef ref+                new_buf <-+                  if not (bufferIsWritable buf)+                     then do b <- flushReadBuffer (haFD handle_) buf+                             return b{ bufState=WriteBuffer }+                     else return buf+                writeIORef ref new_buf+                act handle_+      _other               -> act handle_++-- ---------------------------------------------------------------------------+-- Wrapper for read operations.++wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a+wantReadableHandle fun h@(FileHandle  _ m)   act+  = wantReadableHandle' fun h m act+wantReadableHandle fun h@(DuplexHandle _ m _) act+  = wantReadableHandle' fun h m act+  -- ToDo: in the Duplex case, we don't need to checkReadableHandle++wantReadableHandle'+        :: String -> Handle -> MVar Handle__+        -> (Handle__ -> IO a) -> IO a+wantReadableHandle' fun h m act+  = withHandle_' fun h m (checkReadableHandle act)++checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a+checkReadableHandle act handle_ =+    case haType handle_ of+      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      AppendHandle         -> ioe_notReadable+      WriteHandle          -> ioe_notReadable+      ReadWriteHandle      -> do+        let ref = haBuffer handle_+        buf <- readIORef ref+        when (bufferIsWritable buf) $ do+           new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf+           writeIORef ref new_buf{ bufState=ReadBuffer }+        act handle_+      _other               -> act handle_++-- ---------------------------------------------------------------------------+-- Wrapper for seek operations.++wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a+wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =+  ioException (IOError (Just h) IllegalOperation fun+                   "handle is not seekable" Nothing)+wantSeekableHandle fun h@(FileHandle _ m) act =+  withHandle_' fun h m (checkSeekableHandle act)++checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a+checkSeekableHandle act handle_ =+    case haType handle_ of+      ClosedHandle      -> ioe_closedHandle+      SemiClosedHandle  -> ioe_closedHandle+      AppendHandle      -> ioe_notSeekable+      _  | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_+         | otherwise                                 -> ioe_notSeekable_notBin++-- -----------------------------------------------------------------------------+-- Handy IOErrors++ioe_closedHandle, ioe_EOF,+  ioe_notReadable, ioe_notWritable,+  ioe_notSeekable, ioe_notSeekable_notBin :: IO a++ioe_closedHandle = ioException+   (IOError Nothing IllegalOperation ""+        "handle is closed" Nothing)+ioe_EOF = ioException+   (IOError Nothing EOF "" "" Nothing)+ioe_notReadable = ioException+   (IOError Nothing IllegalOperation ""+        "handle is not open for reading" Nothing)+ioe_notWritable = ioException+   (IOError Nothing IllegalOperation ""+        "handle is not open for writing" Nothing)+ioe_notSeekable = ioException+   (IOError Nothing IllegalOperation ""+        "handle is not seekable" Nothing)+ioe_notSeekable_notBin = ioException+   (IOError Nothing IllegalOperation ""+      "seek operations on text-mode handles are not allowed on this platform"+        Nothing)++ioe_finalizedHandle :: FilePath -> Handle__+ioe_finalizedHandle fp = throw+   (IOError Nothing IllegalOperation ""+        "handle is finalized" (Just fp))++ioe_bufsiz :: Int -> IO a+ioe_bufsiz n = ioException+   (IOError Nothing InvalidArgument "hSetBuffering"+        ("illegal buffer size " ++ showsPrec 9 n []) Nothing)+                                -- 9 => should be parens'ified.++-- -----------------------------------------------------------------------------+-- Handle Finalizers++-- For a duplex handle, we arrange that the read side points to the write side+-- (and hence keeps it alive if the read side is alive).  This is done by+-- having the haOtherSide field of the read side point to the read side.+-- The finalizer is then placed on the write side, and the handle only gets+-- finalized once, when both sides are no longer required.++-- NOTE about finalized handles: It's possible that a handle can be+-- finalized and then we try to use it later, for example if the+-- handle is referenced from another finalizer, or from a thread that+-- has become unreferenced and then resurrected (arguably in the+-- latter case we shouldn't finalize the Handle...).  Anyway,+-- we try to emit a helpful message which is better than nothing.++stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()+stdHandleFinalizer fp m = do+  h_ <- takeMVar m+  flushWriteBufferOnly h_+  putMVar m (ioe_finalizedHandle fp)++handleFinalizer :: FilePath -> MVar Handle__ -> IO ()+handleFinalizer fp m = do+  handle_ <- takeMVar m+  case haType handle_ of+      ClosedHandle -> return ()+      _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()+                -- ignore errors and async exceptions, and close the+                -- descriptor anyway...+              hClose_handle_ handle_+              return ()+  putMVar m (ioe_finalizedHandle fp)++-- ---------------------------------------------------------------------------+-- Grimy buffer operations++checkBufferInvariants :: Handle__ -> IO ()+#ifdef DEBUG+checkBufferInvariants h_ = do+ let ref = haBuffer h_+ Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref+ if not (+        size > 0+        && r <= w+        && w <= size+        && ( r /= w || (r == 0 && w == 0) )+        && ( state /= WriteBuffer || r == 0 )+        && ( state /= WriteBuffer || w < size ) -- write buffer is never full+     )+   then error "buffer invariant violation"+   else return ()+#else+checkBufferInvariants _ = return ()+#endif++newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer+newEmptyBuffer b state size+  = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }++allocateBuffer :: Int -> BufferState -> IO Buffer+allocateBuffer sz@(I# size) state = IO $ \s -> +   -- We sometimes need to pass the address of this buffer to+   -- a "safe" foreign call, hence it must be immovable.+  case newPinnedByteArray# size s of { (# s', b #) ->+  (# s', newEmptyBuffer b state sz #) }++writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int+writeCharIntoBuffer slab (I# off) (C# c)+  = IO $ \s -> case writeCharArray# slab off c s of +               s' -> (# s', I# (off +# 1#) #)++readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)+readCharFromBuffer slab (I# off)+  = IO $ \s -> case readCharArray# slab off s of +                 (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #)++getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)+getBuffer fd state = do+  buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state+  ioref  <- newIORef buffer+  is_tty <- fdIsTTY fd++  let buffer_mode +         | is_tty    = LineBuffering +         | otherwise = BlockBuffering Nothing++  return (ioref, buffer_mode)++mkUnBuffer :: IO (IORef Buffer)+mkUnBuffer = do+  buffer <- allocateBuffer 1 ReadBuffer+  newIORef buffer++-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.+flushWriteBufferOnly :: Handle__ -> IO ()+flushWriteBufferOnly h_ = do+  let fd = haFD h_+      ref = haBuffer h_+  buf <- readIORef ref+  new_buf <- if bufferIsWritable buf +                then flushWriteBuffer fd (haIsStream h_) buf +                else return buf+  writeIORef ref new_buf++-- flushBuffer syncs the file with the buffer, including moving the+-- file pointer backwards in the case of a read buffer.+flushBuffer :: Handle__ -> IO ()+flushBuffer h_ = do+  let ref = haBuffer h_+  buf <- readIORef ref++  flushed_buf <-+    case bufState buf of+      ReadBuffer  -> flushReadBuffer  (haFD h_) buf+      WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf++  writeIORef ref flushed_buf++-- When flushing a read buffer, we seek backwards by the number of+-- characters in the buffer.  The file descriptor must therefore be+-- seekable: attempting to flush the read buffer on an unseekable+-- handle is not allowed.++flushReadBuffer :: FD -> Buffer -> IO Buffer+flushReadBuffer fd buf+  | bufferEmpty buf = return buf+  | otherwise = do+     let off = negate (bufWPtr buf - bufRPtr buf)+#    ifdef DEBUG_DUMP+     puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")+#    endif+     throwErrnoIfMinus1Retry "flushReadBuffer"+         (c_lseek fd (fromIntegral off) sEEK_CUR)+     return buf{ bufWPtr=0, bufRPtr=0 }++flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer+flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  =+  seq fd $ do -- strictness hack+  let bytes = w - r+#ifdef DEBUG_DUMP+  puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")+#endif+  if bytes == 0+     then return (buf{ bufRPtr=0, bufWPtr=0 })+     else do+  res <- writeRawBuffer "flushWriteBuffer" fd is_stream b +                        (fromIntegral r) (fromIntegral bytes)+  let res' = fromIntegral res+  if res' < bytes +     then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })+     else return buf{ bufRPtr=0, bufWPtr=0 }++fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer+fillReadBuffer fd is_line is_stream+      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =+  -- buffer better be empty:+  assert (r == 0 && w == 0) $ do+  fillReadBufferLoop fd is_line is_stream buf b w size++-- For a line buffer, we just get the first chunk of data to arrive,+-- and don't wait for the whole buffer to be full (but we *do* wait+-- until some data arrives).  This isn't really line buffering, but it+-- appears to be what GHC has done for a long time, and I suspect it+-- is more useful than line buffering in most cases.++fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int+                   -> IO Buffer+fillReadBufferLoop fd is_line is_stream buf b w size = do+  let bytes = size - w+  if bytes == 0  -- buffer full?+     then return buf{ bufRPtr=0, bufWPtr=w }+     else do+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")+#endif+  res <- readRawBuffer "fillReadBuffer" fd is_stream b+                       (fromIntegral w) (fromIntegral bytes)+  let res' = fromIntegral res+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoop:  res' = " ++ show res' ++ "\n")+#endif+  if res' == 0+     then if w == 0+             then ioe_EOF+             else return buf{ bufRPtr=0, bufWPtr=w }+     else if res' < bytes && not is_line+             then fillReadBufferLoop fd is_line is_stream buf b (w+res') size+             else return buf{ bufRPtr=0, bufWPtr=w+res' }+ ++fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer+fillReadBufferWithoutBlocking fd is_stream+      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =+  -- buffer better be empty:+  assert (r == 0 && w == 0) $ do+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")+#endif+  res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b+                       0 (fromIntegral size)+  let res' = fromIntegral res+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoopNoBlock:  res' = " ++ show res' ++ "\n")+#endif+  return buf{ bufRPtr=0, bufWPtr=res' }+ +-- Low level routines for reading/writing to (raw)buffers:++#ifndef mingw32_HOST_OS++{-+NOTE [nonblock]:++Unix has broken semantics when it comes to non-blocking I/O: you can+set the O_NONBLOCK flag on an FD, but it applies to the all other FDs+attached to the same underlying file, pipe or TTY; there's no way to+have private non-blocking behaviour for an FD.  See bug #724.++We fix this by only setting O_NONBLOCK on FDs that we create; FDs that+come from external sources or are exposed externally are left in+blocking mode.  This solution has some problems though.  We can't+completely simulate a non-blocking read without O_NONBLOCK: several+cases are wrong here.  The cases that are wrong:++  * reading/writing to a blocking FD in non-threaded mode.+    In threaded mode, we just make a safe call to read().  +    In non-threaded mode we call select() before attempting to read,+    but that leaves a small race window where the data can be read+    from the file descriptor before we issue our blocking read().+  * readRawBufferNoBlock for a blocking FD++NOTE [2363]:++In the threaded RTS we could just make safe calls to read()/write()+for file descriptors in blocking mode without worrying about blocking+other threads, but the problem with this is that the thread will be+uninterruptible while it is blocked in the foreign call.  See #2363.+So now we always call fdReady() before reading, and if fdReady+indicates that there's no data, we call threadWaitRead.++-}++readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBuffer loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- throwErrnoIfMinus1 loc +                                (unsafe_fdReady (fromIntegral fd) 0 0 0)+                      if r /= 0+                        then read+                        else do threadWaitRead (fromIntegral fd); read+  where+    do_read call = throwErrnoIfMinus1RetryMayBlock loc call +                            (threadWaitRead (fromIntegral fd))+    read        = if threaded then safe_read else unsafe_read+    unsafe_read = do_read (read_rawBuffer fd buf off len)+    safe_read   = do_read (safe_read_rawBuffer fd buf off len)++readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtr loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- throwErrnoIfMinus1 loc +                                (unsafe_fdReady (fromIntegral fd) 0 0 0)+                      if r /= 0 +                        then read+                        else do threadWaitRead (fromIntegral fd); read+  where+    do_read call = throwErrnoIfMinus1RetryMayBlock loc call +                            (threadWaitRead (fromIntegral fd))+    read        = if threaded then safe_read else unsafe_read+    unsafe_read = do_read (read_off fd buf off len)+    safe_read   = do_read (safe_read_off fd buf off len)++readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBufferNoBlock loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0+                      if r /= 0 then safe_read+                                else return 0+       -- XXX see note [nonblock]+ where+   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)+   unsafe_read  = do_read (read_rawBuffer fd buf off len)+   safe_read    = do_read (safe_read_rawBuffer fd buf off len)++readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtrNoBlock loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0+                      if r /= 0 then safe_read+                                else return 0+       -- XXX see note [nonblock]+ where+   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)+   unsafe_read  = do_read (read_off fd buf off len)+   safe_read    = do_read (safe_read_off fd buf off len)++writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+writeRawBuffer loc fd is_nonblock buf off len+  | is_nonblock = unsafe_write -- unsafe is ok, it can't block+  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0+                     if r /= 0 +                        then write+                        else do threadWaitWrite (fromIntegral fd); write+  where  +    do_write call = throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral fd)) +    write        = if threaded then safe_write else unsafe_write+    unsafe_write = do_write (write_rawBuffer fd buf off len)+    safe_write   = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)++writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+writeRawBufferPtr loc fd is_nonblock buf off len+  | is_nonblock = unsafe_write -- unsafe is ok, it can't block+  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0+                     if r /= 0 +                        then write+                        else do threadWaitWrite (fromIntegral fd); write+  where+    do_write call = throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral fd)) +    write         = if threaded then safe_write else unsafe_write+    unsafe_write  = do_write (write_off fd buf off len)+    safe_write    = do_write (safe_write_off (fromIntegral fd) buf off len)++foreign import ccall unsafe "__hscore_PrelHandle_read"+   read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall unsafe "__hscore_PrelHandle_read"+   read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall unsafe "__hscore_PrelHandle_write"+   write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall unsafe "__hscore_PrelHandle_write"+   write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall unsafe "fdReady"+  unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt++#else /* mingw32_HOST_OS.... */++readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBuffer loc fd is_stream buf off len+  | threaded  = blockingReadRawBuffer loc fd is_stream buf off len+  | otherwise = asyncReadRawBuffer loc fd is_stream buf off len++readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtr loc fd is_stream buf off len+  | threaded  = blockingReadRawBufferPtr loc fd is_stream buf off len+  | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len++writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+writeRawBuffer loc fd is_stream buf off len+  | threaded =  blockingWriteRawBuffer loc fd is_stream buf off len+  | otherwise = asyncWriteRawBuffer    loc fd is_stream buf off len++writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+writeRawBufferPtr loc fd is_stream buf off len+  | threaded  = blockingWriteRawBufferPtr loc fd is_stream buf off len+  | otherwise = asyncWriteRawBufferPtr    loc fd is_stream buf off len++-- ToDo: we don't have a non-blocking primitve read on Win32+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBufferNoBlock = readRawBuffer++readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtrNoBlock = readRawBufferPtr+-- Async versions of the read/write primitives, for the non-threaded RTS++asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt+                   -> IO CInt+asyncReadRawBuffer loc fd is_stream buf off len = do+    (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) +                 (fromIntegral len) off buf+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt+                      -> IO CInt+asyncReadRawBufferPtr loc fd is_stream buf off len = do+    (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) +                        (fromIntegral len) (buf `plusPtr` off)+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt+                    -> IO CInt+asyncWriteRawBuffer loc fd is_stream buf off len = do+    (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) +                        (fromIntegral len) off buf+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt+                       -> IO CInt+asyncWriteRawBufferPtr loc fd is_stream buf off len = do+    (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) +                  (fromIntegral len) (buf `plusPtr` off)+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++-- Blocking versions of the read/write primitives, for the threaded RTS++blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt+                      -> IO CInt+blockingReadRawBuffer loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_recv_rawBuffer fd buf off len+blockingReadRawBuffer loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_read_rawBuffer fd buf off len++blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt+                         -> IO CInt+blockingReadRawBufferPtr loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_recv_off fd buf off len+blockingReadRawBufferPtr loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_read_off fd buf off len++blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt+                       -> IO CInt+blockingWriteRawBuffer loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_send_rawBuffer fd buf off len+blockingWriteRawBuffer loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_write_rawBuffer fd buf off len++blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt+                          -> IO CInt+blockingWriteRawBufferPtr loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_send_off fd buf off len+blockingWriteRawBufferPtr loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_write_off fd buf off len++-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.+-- These calls may block, but that's ok.++foreign import ccall safe "__hscore_PrelHandle_recv"+   safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_recv"+   safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_send"+   safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_send"+   safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++#endif++foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool++foreign import ccall safe "__hscore_PrelHandle_read"+   safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_read"+   safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_write"+   safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_write"+   safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++-- ---------------------------------------------------------------------------+-- Standard Handles++-- Three handles are allocated during program initialisation.  The first+-- two manage input or output from the Haskell program's standard input+-- or output channel respectively.  The third manages output to the+-- standard error channel. These handles are initially open.++fd_stdin, fd_stdout, fd_stderr :: FD+fd_stdin  = 0+fd_stdout = 1+fd_stderr = 2++-- | A handle managing input from the Haskell program's standard input channel.+stdin :: Handle+stdin = unsafePerformIO $ do+   -- ToDo: acquire lock+   -- We don't set non-blocking mode on standard handles, because it may+   -- confuse other applications attached to the same TTY/pipe+   -- see Note [nonblock]+   (buf, bmode) <- getBuffer fd_stdin ReadBuffer+   mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode++-- | A handle managing output to the Haskell program's standard output channel.+stdout :: Handle+stdout = unsafePerformIO $ do+   -- ToDo: acquire lock+   -- We don't set non-blocking mode on standard handles, because it may+   -- confuse other applications attached to the same TTY/pipe+   -- see Note [nonblock]+   (buf, bmode) <- getBuffer fd_stdout WriteBuffer+   mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode++-- | A handle managing output to the Haskell program's standard error channel.+stderr :: Handle+stderr = unsafePerformIO $ do+    -- ToDo: acquire lock+   -- We don't set non-blocking mode on standard handles, because it may+   -- confuse other applications attached to the same TTY/pipe+   -- see Note [nonblock]+   buf <- mkUnBuffer+   mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering++-- ---------------------------------------------------------------------------+-- Opening and Closing Files++addFilePathToIOError :: String -> FilePath -> IOException -> IOException+addFilePathToIOError fun fp (IOError h iot _ str _)+  = IOError h iot fun str (Just fp)++-- | Computation 'openFile' @file mode@ allocates and returns a new, open+-- handle to manage the file @file@.  It manages input if @mode@+-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',+-- and both input and output if mode is 'ReadWriteMode'.+--+-- If the file does not exist and it is opened for output, it should be+-- created as a new file.  If @mode@ is 'WriteMode' and the file+-- already exists, then it should be truncated to zero length.+-- Some operating systems delete empty files, so there is no guarantee+-- that the file will exist following an 'openFile' with @mode@+-- 'WriteMode' unless it is subsequently written to successfully.+-- The handle is positioned at the end of the file if @mode@ is+-- 'AppendMode', and otherwise at the beginning (in which case its+-- internal position is 0).+-- The initial buffer mode is implementation-dependent.+--+-- This operation may fail with:+--+--  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;+--+--  * 'isDoesNotExistError' if the file does not exist; or+--+--  * 'isPermissionError' if the user does not have permission to open the file.+--+-- Note: if you will be working with files containing binary data, you'll want to+-- be using 'openBinaryFile'.+openFile :: FilePath -> IOMode -> IO Handle+openFile fp im = +  catch +    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)+    (\e -> ioError (addFilePathToIOError "openFile" fp e))++-- | Like 'openFile', but open the file in binary mode.+-- On Windows, reading a file in text mode (which is the default)+-- will translate CRLF to LF, and writing will translate LF to CRLF.+-- This is usually what you want with text files.  With binary files+-- this is undesirable; also, as usual under Microsoft operating systems,+-- text mode treats control-Z as EOF.  Binary mode turns off all special+-- treatment of end-of-line and end-of-file characters.+-- (See also 'hSetBinaryMode'.)++openBinaryFile :: FilePath -> IOMode -> IO Handle+openBinaryFile fp m =+  catch+    (openFile' fp m True)+    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))++openFile' :: String -> IOMode -> Bool -> IO Handle+openFile' filepath mode binary =+  withCString filepath $ \ f ->++    let +      oflags1 = case mode of+                  ReadMode      -> read_flags+#ifdef mingw32_HOST_OS+                  WriteMode     -> write_flags .|. o_TRUNC+#else+                  WriteMode     -> write_flags+#endif+                  ReadWriteMode -> rw_flags+                  AppendMode    -> append_flags++      binary_flags+          | binary    = o_BINARY+          | otherwise = 0++      oflags = oflags1 .|. binary_flags+    in do++    -- the old implementation had a complicated series of three opens,+    -- which is perhaps because we have to be careful not to open+    -- directories.  However, the man pages I've read say that open()+    -- always returns EISDIR if the file is a directory and was opened+    -- for writing, so I think we're ok with a single open() here...+    fd <- throwErrnoIfMinus1Retry "openFile"+                (c_open f (fromIntegral oflags) 0o666)++    stat@(fd_type,_,_) <- fdStat fd++    h <- fdToHandle_stat fd (Just stat) +              False  -- set_non_blocking+              True   -- is_non_blocking+              False  -- is_socket+              filepath mode binary+            `catchAny` \e -> do c_close fd; throw e+        -- NB. don't forget to close the FD if fdToHandle' fails, otherwise+        -- this FD leaks.+        -- ASSERT: if we just created the file, then fdToHandle' won't fail+        -- (so we don't need to worry about removing the newly created file+        --  in the event of an error).++#ifndef mingw32_HOST_OS+        -- we want to truncate() if this is an open in WriteMode, but only+        -- if the target is a RegularFile.  ftruncate() fails on special files+        -- like /dev/null.+    if mode == WriteMode && fd_type == RegularFile+      then throwErrnoIf (/=0) "openFile" +              (c_ftruncate fd 0)+      else return 0+#endif+    return h+++std_flags, output_flags, read_flags, write_flags, rw_flags,+    append_flags :: CInt+std_flags    = o_NONBLOCK   .|. o_NOCTTY+output_flags = std_flags    .|. o_CREAT+read_flags   = std_flags    .|. o_RDONLY +write_flags  = output_flags .|. o_WRONLY+rw_flags     = output_flags .|. o_RDWR+append_flags = write_flags  .|. o_APPEND++-- ---------------------------------------------------------------------------+-- fdToHandle++fdToHandle_stat :: FD+            -> Maybe (FDType, CDev, CIno)+            -> Bool                     -- set_non_blocking+            -> Bool                     -- is_non_blocking+            -> Bool                     -- is_socket+            -> FilePath+            -> IOMode+            -> Bool+            -> IO Handle++fdToHandle_stat fd mb_stat set_non_blocking is_non_blocking is_socket +                filepath mode binary = do++#ifdef mingw32_HOST_OS+    -- On Windows, the is_stream flag indicates that the Handle is a socket+    let is_stream = is_socket+#else+    when set_non_blocking $ setNonBlockingFD fd+    -- turn on non-blocking mode++    -- On Unix, the is_stream flag indicates that the FD is in non-blocking mode+    let is_stream = is_non_blocking || set_non_blocking+#endif++    let (ha_type, write) =+          case mode of+            ReadMode      -> ( ReadHandle,      False )+            WriteMode     -> ( WriteHandle,     True )+            ReadWriteMode -> ( ReadWriteHandle, True )+            AppendMode    -> ( AppendHandle,    True )++    -- open() won't tell us if it was a directory if we only opened for+    -- reading, so check again.+    (fd_type,dev,ino) <- +      case mb_stat of+        Just x  -> return x+        Nothing -> fdStat fd++    case fd_type of+        Directory -> +           ioException (IOError Nothing InappropriateType "openFile"+                           "is a directory" Nothing) ++        -- regular files need to be locked+        RegularFile -> do+#ifndef mingw32_HOST_OS+           -- On Windows we use explicit exclusion via sopen() to implement+           -- this locking (see __hscore_open()); on Unix we have to+           -- implment it in the RTS.+           r <- lockFile fd dev ino (fromBool write)+           when (r == -1)  $+                ioException (IOError Nothing ResourceBusy "openFile"+                                   "file is locked" Nothing)+#endif+           mkFileHandle fd is_stream filepath ha_type binary++        Stream+           -- only *Streams* can be DuplexHandles.  Other read/write+           -- Handles must share a buffer.+           | ReadWriteHandle <- ha_type -> +                mkDuplexHandle fd is_stream filepath binary+           | otherwise ->+                mkFileHandle   fd is_stream filepath ha_type binary++        RawDevice -> +                mkFileHandle fd is_stream filepath ha_type binary++-- | Old API kept to avoid breaking clients+fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath  -> IOMode -> Bool+            -> IO Handle+fdToHandle' fd mb_type is_socket filepath mode binary+ = do+       let mb_stat = case mb_type of+                        Nothing          -> Nothing+                          -- fdToHandle_stat will do the stat:+                        Just RegularFile -> Nothing+                          -- no stat required for streams etc.:+                        Just other       -> Just (other,0,0)+       fdToHandle_stat fd mb_stat+              is_socket -- set_non_blocking+              False     -- is_non_blocking+              is_socket -- is_socket+              filepath mode binary++fdToHandle :: FD -> IO Handle+fdToHandle fd = do+   mode <- fdGetMode fd+   let fd_str = "<file descriptor: " ++ show fd ++ ">"+   fdToHandle_stat fd Nothing+              False -- set_non_blocking+              False -- is_non_blocking+              False -- is_socket (guess XXX)+              fd_str mode True{-bin mode-}++#ifndef mingw32_HOST_OS+foreign import ccall unsafe "lockFile"+  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt++foreign import ccall unsafe "unlockFile"+  unlockFile :: CInt -> IO CInt+#endif++mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode+        -> IO Handle+mkStdHandle fd filepath ha_type buf bmode = do+   spares <- newIORef BufferListNil+   newFileHandle filepath (stdHandleFinalizer filepath)+            (Handle__ { haFD = fd,+                        haType = ha_type,+                        haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,+                        haIsStream = False, -- means FD is blocking on Unix+                        haBufferMode = bmode,+                        haBuffer = buf,+                        haBuffers = spares,+                        haOtherSide = Nothing+                      })++mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle+mkFileHandle fd is_stream filepath ha_type binary = do+  (buf, bmode) <- getBuffer fd (initBufferState ha_type)++#ifdef mingw32_HOST_OS+  -- On Windows, if this is a read/write handle and we are in text mode,+  -- turn off buffering.  We don't correctly handle the case of switching+  -- from read mode to write mode on a buffered text-mode handle, see bug+  -- \#679.+  bmode2 <- case ha_type of+                 ReadWriteHandle | not binary -> return NoBuffering+                 _other                       -> return bmode+#else+  let bmode2 = bmode+#endif++  spares <- newIORef BufferListNil+  newFileHandle filepath (handleFinalizer filepath)+            (Handle__ { haFD = fd,+                        haType = ha_type,+                        haIsBin = binary,+                        haIsStream = is_stream,+                        haBufferMode = bmode2,+                        haBuffer = buf,+                        haBuffers = spares,+                        haOtherSide = Nothing+                      })++mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle+mkDuplexHandle fd is_stream filepath binary = do+  (w_buf, w_bmode) <- getBuffer fd WriteBuffer+  w_spares <- newIORef BufferListNil+  let w_handle_ = +             Handle__ { haFD = fd,+                        haType = WriteHandle,+                        haIsBin = binary,+                        haIsStream = is_stream,+                        haBufferMode = w_bmode,+                        haBuffer = w_buf,+                        haBuffers = w_spares,+                        haOtherSide = Nothing+                      }+  write_side <- newMVar w_handle_++  (r_buf, r_bmode) <- getBuffer fd ReadBuffer+  r_spares <- newIORef BufferListNil+  let r_handle_ = +             Handle__ { haFD = fd,+                        haType = ReadHandle,+                        haIsBin = binary,+                        haIsStream = is_stream,+                        haBufferMode = r_bmode,+                        haBuffer = r_buf,+                        haBuffers = r_spares,+                        haOtherSide = Just write_side+                      }+  read_side <- newMVar r_handle_++  addMVarFinalizer write_side (handleFinalizer filepath write_side)+  return (DuplexHandle filepath read_side write_side)+   +initBufferState :: HandleType -> BufferState+initBufferState ReadHandle = ReadBuffer+initBufferState _          = WriteBuffer++-- ---------------------------------------------------------------------------+-- Closing a handle++-- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the+-- computation finishes, if @hdl@ is writable its buffer is flushed as+-- for 'hFlush'.+-- Performing 'hClose' on a handle that has already been closed has no effect; +-- doing so is not an error.  All other operations on a closed handle will fail.+-- If 'hClose' fails for any reason, any further operations (apart from+-- 'hClose') on the handle will still fail as if @hdl@ had been successfully+-- closed.++hClose :: Handle -> IO ()+hClose h@(FileHandle _ m)     = do +  mb_exc <- hClose' h m+  case mb_exc of+    Nothing -> return ()+    Just e  -> throwIO e+hClose h@(DuplexHandle _ r w) = do+  mb_exc1 <- hClose' h w+  mb_exc2 <- hClose' h r+  case (do mb_exc1; mb_exc2) of+     Nothing -> return ()+     Just e  -> throwIO e++hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)+hClose' h m = withHandle' "hClose" h m $ hClose_help++-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read+-- or an IO error occurs on a lazy stream.  The semi-closed Handle is+-- then closed immediately.  We have to be careful with DuplexHandles+-- though: we have to leave the closing to the finalizer in that case,+-- because the write side may still be in use.+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)+hClose_help handle_ =+  case haType handle_ of +      ClosedHandle -> return (handle_,Nothing)+      _ -> do flushWriteBufferOnly handle_ -- interruptible+              hClose_handle_ handle_++hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)+hClose_handle_ handle_ = do+    let fd = haFD handle_++    -- close the file descriptor, but not when this is the read+    -- side of a duplex handle.+    -- If an exception is raised by the close(), we want to continue+    -- to close the handle and release the lock if it has one, then +    -- we return the exception to the caller of hClose_help which can+    -- raise it if necessary.+    maybe_exception <- +      case haOtherSide handle_ of+        Nothing -> (do+                      throwErrnoIfMinus1Retry_ "hClose" +#ifdef mingw32_HOST_OS+                                (closeFd (haIsStream handle_) fd)+#else+                                (c_close fd)+#endif+                      return Nothing+                    )+                     `catchException` \e -> return (Just e)++        Just _  -> return Nothing++    -- free the spare buffers+    writeIORef (haBuffers handle_) BufferListNil+    writeIORef (haBuffer  handle_) noBuffer+  +#ifndef mingw32_HOST_OS+    -- unlock it+    unlockFile fd+#endif++    -- we must set the fd to -1, because the finalizer is going+    -- to run eventually and try to close/unlock it.+    return (handle_{ haFD        = -1, +                     haType      = ClosedHandle+                   },+            maybe_exception)++{-# NOINLINE noBuffer #-}+noBuffer :: Buffer+noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer++-----------------------------------------------------------------------------+-- Detecting and changing the size of a file++-- | For a handle @hdl@ which attached to a physical file,+-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.++hFileSize :: Handle -> IO Integer+hFileSize handle =+    withHandle_ "hFileSize" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle              -> ioe_closedHandle+      SemiClosedHandle          -> ioe_closedHandle+      _ -> do flushWriteBufferOnly handle_+              r <- fdFileSize (haFD handle_)+              if r /= -1+                 then return r+                 else ioException (IOError Nothing InappropriateType "hFileSize"+                                   "not a regular file" Nothing)+++-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.++hSetFileSize :: Handle -> Integer -> IO ()+hSetFileSize handle size =+    withHandle_ "hSetFileSize" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle              -> ioe_closedHandle+      SemiClosedHandle          -> ioe_closedHandle+      _ -> do flushWriteBufferOnly handle_+              throwErrnoIf (/=0) "hSetFileSize" +                 (c_ftruncate (haFD handle_) (fromIntegral size))+              return ()++-- ---------------------------------------------------------------------------+-- Detecting the End of Input++-- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns+-- 'True' if no further input can be taken from @hdl@ or for a+-- physical file, if the current I\/O position is equal to the length of+-- the file.  Otherwise, it returns 'False'.+--+-- NOTE: 'hIsEOF' may block, because it is the same as calling+-- 'hLookAhead' and checking for an EOF exception.++hIsEOF :: Handle -> IO Bool+hIsEOF handle =+  catch+     (do hLookAhead handle; return False)+     (\e -> if isEOFError e then return True else ioError e)++-- | The computation 'isEOF' is identical to 'hIsEOF',+-- except that it works only on 'stdin'.++isEOF :: IO Bool+isEOF = hIsEOF stdin++-- ---------------------------------------------------------------------------+-- Looking ahead++-- | Computation 'hLookAhead' returns the next character from the handle+-- without removing it from the input buffer, blocking until a character+-- is available.+--+-- This operation may fail with:+--+--  * 'isEOFError' if the end of file has been reached.++hLookAhead :: Handle -> IO Char+hLookAhead handle =+  wantReadableHandle "hLookAhead"  handle hLookAhead'++hLookAhead' :: Handle__ -> IO Char+hLookAhead' handle_ = do+  let ref     = haBuffer handle_+      fd      = haFD handle_+  buf <- readIORef ref++  -- fill up the read buffer if necessary+  new_buf <- if bufferEmpty buf+                then fillReadBuffer fd True (haIsStream handle_) buf+                else return buf++  writeIORef ref new_buf++  (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)+  return c++-- ---------------------------------------------------------------------------+-- Buffering Operations++-- Three kinds of buffering are supported: line-buffering,+-- block-buffering or no-buffering.  See GHC.IOBase for definition and+-- further explanation of what the type represent.++-- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for+-- handle @hdl@ on subsequent reads and writes.+--+-- If the buffer mode is changed from 'BlockBuffering' or+-- 'LineBuffering' to 'NoBuffering', then+--+--  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';+--+--  * if @hdl@ is not writable, the contents of the buffer is discarded.+--+-- This operation may fail with:+--+--  * 'isPermissionError' if the handle has already been used for reading+--    or writing and the implementation does not allow the buffering mode+--    to be changed.++hSetBuffering :: Handle -> BufferMode -> IO ()+hSetBuffering handle mode =+  withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do+  case haType handle_ of+    ClosedHandle -> ioe_closedHandle+    _ -> do+         {- Note:+            - we flush the old buffer regardless of whether+              the new buffer could fit the contents of the old buffer +              or not.+            - allow a handle's buffering to change even if IO has+              occurred (ANSI C spec. does not allow this, nor did+              the previous implementation of IO.hSetBuffering).+            - a non-standard extension is to allow the buffering+              of semi-closed handles to change [sof 6/98]+          -}+          flushBuffer handle_++          let state = initBufferState (haType handle_)+          new_buf <-+            case mode of+                -- we always have a 1-character read buffer for +                -- unbuffered  handles: it's needed to +                -- support hLookAhead.+              NoBuffering            -> allocateBuffer 1 ReadBuffer+              LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state+              BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state+              BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n+                                      | otherwise -> allocateBuffer n state+          writeIORef (haBuffer handle_) new_buf++          -- for input terminals we need to put the terminal into+          -- cooked or raw mode depending on the type of buffering.+          is_tty <- fdIsTTY (haFD handle_)+          when (is_tty && isReadableHandleType (haType handle_)) $+                case mode of+#ifndef mingw32_HOST_OS+        -- 'raw' mode under win32 is a bit too specialised (and troublesome+        -- for most common uses), so simply disable its use here.+                  NoBuffering -> setCooked (haFD handle_) False+#else+                  NoBuffering -> return ()+#endif+                  _           -> setCooked (haFD handle_) True++          -- throw away spare buffers, they might be the wrong size+          writeIORef (haBuffers handle_) BufferListNil++          return (handle_{ haBufferMode = mode })++-- -----------------------------------------------------------------------------+-- hFlush++-- | The action 'hFlush' @hdl@ causes any items buffered for output+-- in handle @hdl@ to be sent immediately to the operating system.+--+-- This operation may fail with:+--+--  * 'isFullError' if the device is full;+--+--  * 'isPermissionError' if a system resource limit would be exceeded.+--    It is unspecified whether the characters in the buffer are discarded+--    or retained under these circumstances.++hFlush :: Handle -> IO () +hFlush handle =+   wantWritableHandle "hFlush" handle $ \ handle_ -> do+   buf <- readIORef (haBuffer handle_)+   if bufferIsWritable buf && not (bufferEmpty buf)+        then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf+                writeIORef (haBuffer handle_) flushed_buf+        else return ()+++-- -----------------------------------------------------------------------------+-- Repositioning Handles++data HandlePosn = HandlePosn Handle HandlePosition++instance Eq HandlePosn where+    (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2++instance Show HandlePosn where+   showsPrec p (HandlePosn h pos) = +        showsPrec p h . showString " at position " . shows pos++  -- HandlePosition is the Haskell equivalent of POSIX' off_t.+  -- We represent it as an Integer on the Haskell side, but+  -- cheat slightly in that hGetPosn calls upon a C helper+  -- that reports the position back via (merely) an Int.+type HandlePosition = Integer++-- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of+-- @hdl@ as a value of the abstract type 'HandlePosn'.++hGetPosn :: Handle -> IO HandlePosn+hGetPosn handle = do+    posn <- hTell handle+    return (HandlePosn handle posn)++-- | If a call to 'hGetPosn' @hdl@ returns a position @p@,+-- then computation 'hSetPosn' @p@ sets the position of @hdl@+-- to the position it held at the time of the call to 'hGetPosn'.+--+-- This operation may fail with:+--+--  * 'isPermissionError' if a system resource limit would be exceeded.++hSetPosn :: HandlePosn -> IO () +hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i++-- ---------------------------------------------------------------------------+-- hSeek++-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:+data SeekMode+  = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.+  | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@+                        -- from the current position.+  | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@+                        -- from the end of the file.+    deriving (Eq, Ord, Ix, Enum, Read, Show)++{- Note: + - when seeking using `SeekFromEnd', positive offsets (>=0) means+   seeking at or past EOF.++ - we possibly deviate from the report on the issue of seeking within+   the buffer and whether to flush it or not.  The report isn't exactly+   clear here.+-}++-- | Computation 'hSeek' @hdl mode i@ sets the position of handle+-- @hdl@ depending on @mode@.+-- The offset @i@ is given in terms of 8-bit bytes.+--+-- If @hdl@ is block- or line-buffered, then seeking to a position which is not+-- in the current buffer will first cause any items in the output buffer to be+-- written to the device, and then cause the input buffer to be discarded.+-- Some handles may not be seekable (see 'hIsSeekable'), or only support a+-- subset of the possible positioning operations (for instance, it may only+-- be possible to seek to the end of a tape, or to a positive offset from+-- the beginning or current position).+-- It is not possible to set a negative I\/O position, or for+-- a physical file, an I\/O position beyond the current end-of-file.+--+-- This operation may fail with:+--+--  * 'isPermissionError' if a system resource limit would be exceeded.++hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek handle mode offset =+    wantSeekableHandle "hSeek" handle $ \ handle_ -> do+#   ifdef DEBUG_DUMP+    puts ("hSeek " ++ show (mode,offset) ++ "\n")+#   endif+    let ref = haBuffer handle_+    buf <- readIORef ref+    let r = bufRPtr buf+        w = bufWPtr buf+        fd = haFD handle_++    let do_seek =+          throwErrnoIfMinus1Retry_ "hSeek"+            (c_lseek (haFD handle_) (fromIntegral offset) whence)++        whence :: CInt+        whence = case mode of+                   AbsoluteSeek -> sEEK_SET+                   RelativeSeek -> sEEK_CUR+                   SeekFromEnd  -> sEEK_END++    if bufferIsWritable buf+        then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf+                writeIORef ref new_buf+                do_seek+        else do++    if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)+        then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }+        else do ++    new_buf <- flushReadBuffer (haFD handle_) buf+    writeIORef ref new_buf+    do_seek+++hTell :: Handle -> IO Integer+hTell handle = +    wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do++#if defined(mingw32_HOST_OS)+        -- urgh, on Windows we have to worry about \n -> \r\n translation, +        -- so we can't easily calculate the file position using the+        -- current buffer size.  Just flush instead.+      flushBuffer handle_+#endif+      let fd = haFD handle_+      posn <- fromIntegral `liftM`+                throwErrnoIfMinus1Retry "hGetPosn"+                   (c_lseek fd 0 sEEK_CUR)++      let ref = haBuffer handle_+      buf <- readIORef ref++      let real_posn +           | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)+           | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)+#     ifdef DEBUG_DUMP+      puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")+      puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")+#     endif+      return real_posn++-- -----------------------------------------------------------------------------+-- Handle Properties++-- A number of operations return information about the properties of a+-- handle.  Each of these operations returns `True' if the handle has+-- the specified property, and `False' otherwise.++hIsOpen :: Handle -> IO Bool+hIsOpen handle =+    withHandle_ "hIsOpen" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle         -> return False+      SemiClosedHandle     -> return False+      _                    -> return True++hIsClosed :: Handle -> IO Bool+hIsClosed handle =+    withHandle_ "hIsClosed" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle         -> return True+      _                    -> return False++{- not defined, nor exported, but mentioned+   here for documentation purposes:++    hSemiClosed :: Handle -> IO Bool+    hSemiClosed h = do+       ho <- hIsOpen h+       hc <- hIsClosed h+       return (not (ho || hc))+-}++hIsReadable :: Handle -> IO Bool+hIsReadable (DuplexHandle _ _ _) = return True+hIsReadable handle =+    withHandle_ "hIsReadable" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      htype                -> return (isReadableHandleType htype)++hIsWritable :: Handle -> IO Bool+hIsWritable (DuplexHandle _ _ _) = return True+hIsWritable handle =+    withHandle_ "hIsWritable" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      htype                -> return (isWritableHandleType htype)++-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode+-- for @hdl@.++hGetBuffering :: Handle -> IO BufferMode+hGetBuffering handle = +    withHandle_ "hGetBuffering" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      _ -> +           -- We're being non-standard here, and allow the buffering+           -- of a semi-closed handle to be queried.   -- sof 6/98+          return (haBufferMode handle_)  -- could be stricter..++hIsSeekable :: Handle -> IO Bool+hIsSeekable handle =+    withHandle_ "hIsSeekable" handle $ \ handle_ -> do+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      AppendHandle         -> return False+      _                    -> do t <- fdType (haFD handle_)+                                 return ((t == RegularFile    || t == RawDevice)+                                         && (haIsBin handle_  || tEXT_MODE_SEEK_ALLOWED))++-- -----------------------------------------------------------------------------+-- Changing echo status (Non-standard GHC extensions)++-- | Set the echoing status of a handle connected to a terminal.++hSetEcho :: Handle -> Bool -> IO ()+hSetEcho handle on = do+    isT   <- hIsTerminalDevice handle+    if not isT+     then return ()+     else+      withHandle_ "hSetEcho" handle $ \ handle_ -> do+      case haType handle_ of +         ClosedHandle -> ioe_closedHandle+         _            -> setEcho (haFD handle_) on++-- | Get the echoing status of a handle connected to a terminal.++hGetEcho :: Handle -> IO Bool+hGetEcho handle = do+    isT   <- hIsTerminalDevice handle+    if not isT+     then return False+     else+       withHandle_ "hGetEcho" handle $ \ handle_ -> do+       case haType handle_ of +         ClosedHandle -> ioe_closedHandle+         _            -> getEcho (haFD handle_)++-- | Is the handle connected to a terminal?++hIsTerminalDevice :: Handle -> IO Bool+hIsTerminalDevice handle = do+    withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do+     case haType handle_ of +       ClosedHandle -> ioe_closedHandle+       _            -> fdIsTTY (haFD handle_)++-- -----------------------------------------------------------------------------+-- hSetBinaryMode++-- | Select binary mode ('True') or text mode ('False') on a open handle.+-- (See also 'openBinaryFile'.)++hSetBinaryMode :: Handle -> Bool -> IO ()+hSetBinaryMode handle bin =+  withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->+    do throwErrnoIfMinus1_ "hSetBinaryMode"+          (setmode (haFD handle_) bin)+       return handle_{haIsBin=bin}+  +foreign import ccall unsafe "__hscore_setmode"+  setmode :: CInt -> Bool -> IO CInt++-- -----------------------------------------------------------------------------+-- Duplicating a Handle++-- | Returns a duplicate of the original handle, with its own buffer.+-- The two Handles will share a file pointer, however.  The original+-- handle's buffer is flushed, including discarding any input data,+-- before the handle is duplicated.++hDuplicate :: Handle -> IO Handle+hDuplicate h@(FileHandle path m) = do+  new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)+  newFileHandle path (handleFinalizer path) new_h_+hDuplicate h@(DuplexHandle path r w) = do+  new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)+  new_w <- newMVar new_w_+  new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))+  new_r <- newMVar new_r_+  addMVarFinalizer new_w (handleFinalizer path new_w)+  return (DuplexHandle path new_r new_w)++dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__+          -> IO (Handle__, Handle__)+dupHandle h other_side h_ = do+  -- flush the buffer first, so we don't have to copy its contents+  flushBuffer h_+  new_fd <- case other_side of+                Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)+                Just r -> withHandle_' "dupHandle" h r (return . haFD)+  dupHandle_ other_side h_ new_fd++dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__+            -> IO (Handle__, Handle__)+dupHandleTo other_side hto_ h_ = do+  flushBuffer h_+  -- Windows' dup2 does not return the new descriptor, unlike Unix+  throwErrnoIfMinus1 "dupHandleTo" $ +        c_dup2 (haFD h_) (haFD hto_)+  dupHandle_ other_side h_ (haFD hto_)++dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD+           -> IO (Handle__, Handle__)+dupHandle_ other_side h_ new_fd = do+  buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))+  ioref <- newIORef buffer+  ioref_buffers <- newIORef BufferListNil++  let new_handle_ = h_{ haFD = new_fd, +                        haBuffer = ioref, +                        haBuffers = ioref_buffers,+                        haOtherSide = other_side }+  return (h_, new_handle_)++-- -----------------------------------------------------------------------------+-- Replacing a Handle++{- |+Makes the second handle a duplicate of the first handle.  The second +handle will be closed first, if it is not already.++This can be used to retarget the standard Handles, for example:++> do h <- openFile "mystdout" WriteMode+>    hDuplicateTo h stdout+-}++hDuplicateTo :: Handle -> Handle -> IO ()+hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do+   _ <- hClose_help h2_+   withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)+hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do+ withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do+   _ <- hClose_help w2_+   withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)+ withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do+   _ <- hClose_help r2_+   withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)+hDuplicateTo h1 _ =+   ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" +                "handles are incompatible" Nothing)++-- ---------------------------------------------------------------------------+-- showing Handles.+--+-- | 'hShow' is in the 'IO' monad, and gives more comprehensive output+-- than the (pure) instance of 'Show' for 'Handle'.++hShow :: Handle -> IO String+hShow h@(FileHandle path _) = showHandle' path False h+hShow h@(DuplexHandle path _ _) = showHandle' path True h++showHandle' :: String -> Bool -> Handle -> IO String+showHandle' filepath is_duplex h = +  withHandle_ "showHandle" h $ \hdl_ ->+    let+     showType | is_duplex = showString "duplex (read-write)"+              | otherwise = shows (haType hdl_)+    in+    return +      (( showChar '{' . +        showHdl (haType hdl_) +            (showString "loc=" . showString filepath . showChar ',' .+             showString "type=" . showType . showChar ',' .+             showString "binary=" . shows (haIsBin hdl_) . showChar ',' .+             showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )+      ) "")+   where++    showHdl :: HandleType -> ShowS -> ShowS+    showHdl ht cont = +       case ht of+        ClosedHandle  -> shows ht . showString "}"+        _ -> cont++    showBufMode :: Buffer -> BufferMode -> ShowS+    showBufMode buf bmo =+      case bmo of+        NoBuffering   -> showString "none"+        LineBuffering -> showString "line"+        BlockBuffering (Just n) -> showString "block " . showParen True (shows n)+        BlockBuffering Nothing  -> showString "block " . showParen True (shows def)+      where+       def :: Int +       def = bufSize buf++-- ---------------------------------------------------------------------------+-- debugging++#if defined(DEBUG_DUMP)+puts :: String -> IO ()+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))+            return ()+#endif++-- -----------------------------------------------------------------------------+-- utils++throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt+throwErrnoIfMinus1RetryOnBlock loc f on_block  = +  do+    res <- f+    if (res :: CInt) == -1+      then do+        err <- getErrno+        if err == eINTR+          then throwErrnoIfMinus1RetryOnBlock loc f on_block+          else if err == eWOULDBLOCK || err == eAGAIN+                 then do on_block+                 else throwErrno loc+      else return res++-- -----------------------------------------------------------------------------+-- wrappers to platform-specific constants:++foreign import ccall unsafe "__hscore_supportsTextMode"+  tEXT_MODE_SEEK_ALLOWED :: Bool++foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
+ lib/base/src/GHC/Handle.hs-boot view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Handle where++import GHC.IOBase++stdout :: Handle+stderr :: Handle+hFlush :: Handle -> IO ()
+ lib/base/src/GHC/IO.hs view
@@ -0,0 +1,974 @@+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}+{-# OPTIONS_HADDOCK hide #-}++#undef DEBUG_DUMP++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.IO+-- Copyright   :  (c) The University of Glasgow, 1992-2001+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- String I\/O functions+--+-----------------------------------------------------------------------------++-- #hide+module GHC.IO ( +   hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,+   commitBuffer',       -- hack, see below+   hGetcBuffered,       -- needed by ghc/compiler/utils/StringBuffer.lhs+   hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,+   memcpy_ba_baoff,+   memcpy_ptr_baoff,+   memcpy_baoff_ba,+   memcpy_baoff_ptr,+ ) where++import Foreign+import Foreign.C++import System.IO.Error+import Data.Maybe+import Control.Monad+#ifndef mingw32_HOST_OS+import System.Posix.Internals+#endif++import GHC.Enum+import GHC.Base+import GHC.IOBase+import GHC.Handle       -- much of the real stuff is in here+import GHC.Real+import GHC.Num+import GHC.Show+import GHC.List++#ifdef mingw32_HOST_OS+import GHC.Conc+#endif++-- ---------------------------------------------------------------------------+-- Simple input operations++-- If hWaitForInput finds anything in the Handle's buffer, it+-- immediately returns.  If not, it tries to read from the underlying+-- OS handle. Notice that for buffered Handles connected to terminals+-- this means waiting until a complete line is available.++-- | Computation 'hWaitForInput' @hdl t@+-- waits until input is available on handle @hdl@.+-- It returns 'True' as soon as input is available on @hdl@,+-- or 'False' if no input is available within @t@ milliseconds.+--+-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.+--+-- This operation may fail with:+--+--  * 'isEOFError' if the end of file has been reached.+--+-- NOTE for GHC users: unless you use the @-threaded@ flag,+-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell+-- threads for the duration of the call.  It behaves like a+-- @safe@ foreign call in this respect.++hWaitForInput :: Handle -> Int -> IO Bool+hWaitForInput h msecs = do+  wantReadableHandle "hWaitForInput" h $ \ handle_ -> do+  let ref = haBuffer handle_+  buf <- readIORef ref++  if not (bufferEmpty buf)+        then return True+        else do++  if msecs < 0 +        then do buf' <- fillReadBuffer (haFD handle_) True +                                (haIsStream handle_) buf+                writeIORef ref buf'+                return True+        else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $+                     fdReady (haFD handle_) 0 {- read -}+                                (fromIntegral msecs)+                                (fromIntegral $ fromEnum $ haIsStream handle_)+                if r /= 0 then do -- Call hLookAhead' to throw an EOF+                                  -- exception if appropriate+                                  hLookAhead' handle_+                                  return True+                          else return False++foreign import ccall safe "fdReady"+  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt++-- ---------------------------------------------------------------------------+-- hGetChar++-- | Computation 'hGetChar' @hdl@ reads a character from the file or+-- channel managed by @hdl@, blocking until a character is available.+--+-- This operation may fail with:+--+--  * 'isEOFError' if the end of file has been reached.++hGetChar :: Handle -> IO Char+hGetChar handle =+  wantReadableHandle "hGetChar" handle $ \handle_ -> do++  let fd = haFD handle_+      ref = haBuffer handle_++  buf <- readIORef ref+  if not (bufferEmpty buf)+        then hGetcBuffered fd ref buf+        else do++  -- buffer is empty.+  case haBufferMode handle_ of+    LineBuffering    -> do+        new_buf <- fillReadBuffer fd True (haIsStream handle_) buf+        hGetcBuffered fd ref new_buf+    BlockBuffering _ -> do+        new_buf <- fillReadBuffer fd True (haIsStream handle_) buf+                --                   ^^^^+                -- don't wait for a completely full buffer.+        hGetcBuffered fd ref new_buf+    NoBuffering -> do+        -- make use of the minimal buffer we already have+        let raw = bufBuf buf+        r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1+        if r == 0+           then ioe_EOF+           else do (c,_) <- readCharFromBuffer raw 0+                   return c++hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char+hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w }+ = do (c, r) <- readCharFromBuffer b r0+      let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }+                  | otherwise = buf{ bufRPtr=r }+      writeIORef ref new_buf+      return c++-- ---------------------------------------------------------------------------+-- hGetLine++-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for+-- the duration.++-- | Computation 'hGetLine' @hdl@ reads a line from the file or+-- channel managed by @hdl@.+--+-- This operation may fail with:+--+--  * 'isEOFError' if the end of file is encountered when reading+--    the /first/ character of the line.+--+-- If 'hGetLine' encounters end-of-file at any other point while reading+-- in a line, it is treated as a line terminator and the (partial)+-- line is returned.++hGetLine :: Handle -> IO String+hGetLine h = do+  m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do+        case haBufferMode handle_ of+           NoBuffering      -> return Nothing+           LineBuffering    -> do+              l <- hGetLineBuffered handle_+              return (Just l)+           BlockBuffering _ -> do +              l <- hGetLineBuffered handle_+              return (Just l)+  case m of+        Nothing -> hGetLineUnBuffered h+        Just l  -> return l++hGetLineBuffered :: Handle__ -> IO String+hGetLineBuffered handle_ = do+  let ref = haBuffer handle_+  buf <- readIORef ref+  hGetLineBufferedLoop handle_ ref buf []++hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]+                     -> IO String+hGetLineBufferedLoop handle_ ref+        buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss =+  let+        -- find the end-of-line character, if there is one+        loop raw r+           | r == w = return (False, w)+           | otherwise =  do+                (c,r') <- readCharFromBuffer raw r+                if c == '\n'+                   then return (True, r) -- NB. not r': don't include the '\n'+                   else loop raw r'+  in do+  (eol, off) <- loop raw0 r0++#ifdef DEBUG_DUMP+  puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")+#endif++  xs <- unpack raw0 r0 off++  -- if eol == True, then off is the offset of the '\n'+  -- otherwise off == w and the buffer is now empty.+  if eol+        then do if (w == off + 1)+                        then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }+                        else writeIORef ref buf{ bufRPtr = off + 1 }+                return (concat (reverse (xs:xss)))+        else do+             maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)+                                buf{ bufWPtr=0, bufRPtr=0 }+             case maybe_buf of+                -- Nothing indicates we caught an EOF, and we may have a+                -- partial line to return.+                Nothing -> do+                     writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }+                     let str = concat (reverse (xs:xss))+                     if not (null str)+                        then return str+                        else ioe_EOF+                Just new_buf ->+                     hGetLineBufferedLoop handle_ ref new_buf (xs:xss)++maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer)+maybeFillReadBuffer fd is_line is_stream buf+  = catch +     (do buf' <- fillReadBuffer fd is_line is_stream buf+         return (Just buf')+     )+     (\e -> do if isEOFError e +                  then return Nothing +                  else ioError e)+++unpack :: RawBuffer -> Int -> Int -> IO [Char]+unpack _   _      0        = return ""+unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s+   where+    unpackRB acc i s+     | i <# r  = (# s, acc #)+     | otherwise = +          case readCharArray# buf i s of+          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'+++hGetLineUnBuffered :: Handle -> IO String+hGetLineUnBuffered h = do+  c <- hGetChar h+  if c == '\n' then+     return ""+   else do+    l <- getRest+    return (c:l)+ where+  getRest = do+    c <- +      catch +        (hGetChar h)+        (\ err -> do+          if isEOFError err then+             return '\n'+           else+             ioError err)+    if c == '\n' then+       return ""+     else do+       s <- getRest+       return (c:s)++-- -----------------------------------------------------------------------------+-- hGetContents++-- hGetContents on a DuplexHandle only affects the read side: you can+-- carry on writing to it afterwards.++-- | Computation 'hGetContents' @hdl@ returns the list of characters+-- corresponding to the unread portion of the channel or file managed+-- by @hdl@, which is put into an intermediate state, /semi-closed/.+-- In this state, @hdl@ is effectively closed,+-- but items are read from @hdl@ on demand and accumulated in a special+-- list returned by 'hGetContents' @hdl@.+--+-- Any operation that fails because a handle is closed,+-- also fails if a handle is semi-closed.  The only exception is 'hClose'.+-- A semi-closed handle becomes closed:+--+--  * if 'hClose' is applied to it;+--+--  * if an I\/O error occurs when reading an item from the handle;+--+--  * or once the entire contents of the handle has been read.+--+-- Once a semi-closed handle becomes closed, the contents of the+-- associated list becomes fixed.  The contents of this final list is+-- only partially specified: it will contain at least all the items of+-- the stream that were evaluated prior to the handle becoming closed.+--+-- Any I\/O errors encountered while a handle is semi-closed are simply+-- discarded.+--+-- This operation may fail with:+--+--  * 'isEOFError' if the end of file has been reached.++hGetContents :: Handle -> IO String+hGetContents handle = +    withHandle "hGetContents" handle $ \handle_ ->+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      AppendHandle         -> ioe_notReadable+      WriteHandle          -> ioe_notReadable+      _ -> do xs <- lazyRead handle+              return (handle_{ haType=SemiClosedHandle}, xs )++-- Note that someone may close the semi-closed handle (or change its+-- buffering), so each time these lazy read functions are pulled on,+-- they have to check whether the handle has indeed been closed.++lazyRead :: Handle -> IO String+lazyRead handle = +   unsafeInterleaveIO $+        withHandle "lazyRead" handle $ \ handle_ -> do+        case haType handle_ of+          ClosedHandle     -> return (handle_, "")+          SemiClosedHandle -> lazyRead' handle handle_+          _ -> ioException +                  (IOError (Just handle) IllegalOperation "lazyRead"+                        "illegal handle type" Nothing)++lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char])+lazyRead' h handle_ = do+  let ref = haBuffer handle_+      fd  = haFD handle_++  -- even a NoBuffering handle can have a char in the buffer... +  -- (see hLookAhead)+  buf <- readIORef ref+  if not (bufferEmpty buf)+        then lazyReadHaveBuffer h handle_ fd ref buf+        else do++  case haBufferMode handle_ of+     NoBuffering      -> do+        -- make use of the minimal buffer we already have+        let raw = bufBuf buf+        r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1+        if r == 0+           then do (handle_', _) <- hClose_help handle_ +                   return (handle_', "")+           else do (c,_) <- readCharFromBuffer raw 0+                   rest <- lazyRead h+                   return (handle_, c : rest)++     LineBuffering    -> lazyReadBuffered h handle_ fd ref buf+     BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf++-- we never want to block during the read, so we call fillReadBuffer with+-- is_line==True, which tells it to "just read what there is".+lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer+                 -> IO (Handle__, [Char])+lazyReadBuffered h handle_ fd ref buf = do+   catch +        (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf+            lazyReadHaveBuffer h handle_ fd ref buf'+        )+        -- all I/O errors are discarded.  Additionally, we close the handle.+        (\_ -> do (handle_', _) <- hClose_help handle_+                  return (handle_', "")+        )++lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char])+lazyReadHaveBuffer h handle_ _ ref buf = do+   more <- lazyRead h+   writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }+   s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more+   return (handle_, s)+++unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]+unpackAcc _   _      0        acc  = return acc+unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s+   where+    unpackRB acc i s+     | i <# r  = (# s, acc #)+     | otherwise = +          case readCharArray# buf i s of+          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'++-- ---------------------------------------------------------------------------+-- hPutChar++-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the+-- file or channel managed by @hdl@.  Characters may be buffered if+-- buffering is enabled for @hdl@.+--+-- This operation may fail with:+--+--  * 'isFullError' if the device is full; or+--+--  * 'isPermissionError' if another system resource limit would be exceeded.++hPutChar :: Handle -> Char -> IO ()+hPutChar handle c = do+    c `seq` return ()+    wantWritableHandle "hPutChar" handle $ \ handle_  -> do+    let fd = haFD handle_+    case haBufferMode handle_ of+        LineBuffering    -> hPutcBuffered handle_ True  c+        BlockBuffering _ -> hPutcBuffered handle_ False c+        NoBuffering      ->+                with (castCharToCChar c) $ \buf -> do+                  writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1+                  return ()++hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()+hPutcBuffered handle_ is_line c = do+  let ref = haBuffer handle_+  buf <- readIORef ref+  let w = bufWPtr buf+  w'  <- writeCharIntoBuffer (bufBuf buf) w c+  let new_buf = buf{ bufWPtr = w' }+  if bufferFull new_buf || is_line && c == '\n'+     then do +        flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf+        writeIORef ref flushed_buf+     else do +        writeIORef ref new_buf+++hPutChars :: Handle -> [Char] -> IO ()+hPutChars _      [] = return ()+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs++-- ---------------------------------------------------------------------------+-- hPutStr++-- We go to some trouble to avoid keeping the handle locked while we're+-- evaluating the string argument to hPutStr, in case doing so triggers another+-- I/O operation on the same handle which would lead to deadlock.  The classic+-- case is+--+--              putStr (trace "hello" "world")+--+-- so the basic scheme is this:+--+--      * copy the string into a fresh buffer,+--      * "commit" the buffer to the handle.+--+-- Committing may involve simply copying the contents of the new+-- buffer into the handle's buffer, flushing one or both buffers, or+-- maybe just swapping the buffers over (if the handle's buffer was+-- empty).  See commitBuffer below.++-- | Computation 'hPutStr' @hdl s@ writes the string+-- @s@ to the file or channel managed by @hdl@.+--+-- This operation may fail with:+--+--  * 'isFullError' if the device is full; or+--+--  * 'isPermissionError' if another system resource limit would be exceeded.++hPutStr :: Handle -> String -> IO ()+hPutStr handle str = do+    buffer_mode <- wantWritableHandle "hPutStr" handle +                        (\ handle_ -> do getSpareBuffer handle_)+    case buffer_mode of+       (NoBuffering, _) -> do+            hPutChars handle str        -- v. slow, but we don't care+       (LineBuffering, buf) -> do+            writeLines handle buf str+       (BlockBuffering _, buf) -> do+            writeBlocks handle buf str+++getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)+getSpareBuffer Handle__{haBuffer=ref, +                        haBuffers=spare_ref,+                        haBufferMode=mode}+ = do+   case mode of+     NoBuffering -> return (mode, error "no buffer!")+     _ -> do+          bufs <- readIORef spare_ref+          buf  <- readIORef ref+          case bufs of+            BufferListCons b rest -> do+                writeIORef spare_ref rest+                return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))+            BufferListNil -> do+                new_buf <- allocateBuffer (bufSize buf) WriteBuffer+                return (mode, new_buf)+++writeLines :: Handle -> Buffer -> String -> IO ()+writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =+  let+   shoveString :: Int -> [Char] -> IO ()+        -- check n == len first, to ensure that shoveString is strict in n.+   shoveString n cs | n == len = do+        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False+        writeLines hdl new_buf cs+   shoveString n [] = do+        commitBuffer hdl raw len n False{-no flush-} True{-release-}+        return ()+   shoveString n (c:cs) = do+        n' <- writeCharIntoBuffer raw n c+        if (c == '\n') +         then do +              new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False+              writeLines hdl new_buf cs+         else +              shoveString n' cs+  in+  shoveString 0 s++writeBlocks :: Handle -> Buffer -> String -> IO ()+writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =+  let+   shoveString :: Int -> [Char] -> IO ()+        -- check n == len first, to ensure that shoveString is strict in n.+   shoveString n cs | n == len = do+        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False+        writeBlocks hdl new_buf cs+   shoveString n [] = do+        commitBuffer hdl raw len n False{-no flush-} True{-release-}+        return ()+   shoveString n (c:cs) = do+        n' <- writeCharIntoBuffer raw n c+        shoveString n' cs+  in+  shoveString 0 s++-- -----------------------------------------------------------------------------+-- commitBuffer handle buf sz count flush release+-- +-- Write the contents of the buffer 'buf' ('sz' bytes long, containing+-- 'count' bytes of data) to handle (handle must be block or line buffered).+-- +-- Implementation:+-- +--    for block/line buffering,+--       1. If there isn't room in the handle buffer, flush the handle+--          buffer.+-- +--       2. If the handle buffer is empty,+--               if flush, +--                   then write buf directly to the device.+--                   else swap the handle buffer with buf.+-- +--       3. If the handle buffer is non-empty, copy buf into the+--          handle buffer.  Then, if flush != 0, flush+--          the buffer.++commitBuffer+        :: Handle                       -- handle to commit to+        -> RawBuffer -> Int             -- address and size (in bytes) of buffer+        -> Int                          -- number of bytes of data in buffer+        -> Bool                         -- True <=> flush the handle afterward+        -> Bool                         -- release the buffer?+        -> IO Buffer++commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do+  wantWritableHandle "commitAndReleaseBuffer" hdl $+     commitBuffer' raw sz count flush release++-- Explicitly lambda-lift this function to subvert GHC's full laziness+-- optimisations, which otherwise tends to float out subexpressions+-- past the \handle, which is really a pessimisation in this case because+-- that lambda is a one-shot lambda.+--+-- Don't forget to export the function, to stop it being inlined too+-- (this appears to be better than NOINLINE, because the strictness+-- analyser still gets to worker-wrapper it).+--+-- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001+--+commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__+              -> IO Buffer+commitBuffer' raw sz@(I# _) count@(I# _) flush release+  handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do++#ifdef DEBUG_DUMP+      puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count+            ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")+#endif++      old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }+          <- readIORef ref++      buf_ret <-+        -- enough room in handle buffer?+         if (not flush && (size - w > count))+                -- The > is to be sure that we never exactly fill+                -- up the buffer, which would require a flush.  So+                -- if copying the new data into the buffer would+                -- make the buffer full, we just flush the existing+                -- buffer and the new data immediately, rather than+                -- copying before flushing.++                -- not flushing, and there's enough room in the buffer:+                -- just copy the data in and update bufWPtr.+            then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)+                    writeIORef ref old_buf{ bufWPtr = w + count }+                    return (newEmptyBuffer raw WriteBuffer sz)++                -- else, we have to flush+            else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf++                    let this_buf = +                            Buffer{ bufBuf=raw, bufState=WriteBuffer, +                                    bufRPtr=0, bufWPtr=count, bufSize=sz }++                        -- if:  (a) we don't have to flush, and+                        --      (b) size(new buffer) == size(old buffer), and+                        --      (c) new buffer is not full,+                        -- we can just just swap them over...+                    if (not flush && sz == size && count /= sz)+                        then do +                          writeIORef ref this_buf+                          return flushed_buf                         ++                        -- otherwise, we have to flush the new data too,+                        -- and start with a fresh buffer+                        else do+                          flushWriteBuffer fd (haIsStream handle_) this_buf+                          writeIORef ref flushed_buf+                            -- if the sizes were different, then allocate+                            -- a new buffer of the correct size.+                          if sz == size+                             then return (newEmptyBuffer raw WriteBuffer sz)+                             else allocateBuffer size WriteBuffer++      -- release the buffer if necessary+      case buf_ret of+        Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do+          if release && buf_ret_sz == size+            then do+              spare_bufs <- readIORef spare_buf_ref+              writeIORef spare_buf_ref +                (BufferListCons buf_ret_raw spare_bufs)+              return buf_ret+            else+              return buf_ret++-- ---------------------------------------------------------------------------+-- Reading/writing sequences of bytes.++-- ---------------------------------------------------------------------------+-- hPutBuf++-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the+-- buffer @buf@ to the handle @hdl@.  It returns ().+--+-- This operation may fail with:+--+--  * 'ResourceVanished' if the handle is a pipe or socket, and the+--    reading end is closed.  (If this is a POSIX system, and the program+--    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered+--    instead, whose default action is to terminate the program).++hPutBuf :: Handle                       -- handle to write to+        -> Ptr a                        -- address of buffer+        -> Int                          -- number of bytes of data in buffer+        -> IO ()+hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()++hPutBufNonBlocking+        :: Handle                       -- handle to write to+        -> Ptr a                        -- address of buffer+        -> Int                          -- number of bytes of data in buffer+        -> IO Int                       -- returns: number of bytes written+hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False++hPutBuf':: Handle                       -- handle to write to+        -> Ptr a                        -- address of buffer+        -> Int                          -- number of bytes of data in buffer+        -> Bool                         -- allow blocking?+        -> IO Int+hPutBuf' handle ptr count can_block+  | count == 0 = return 0+  | count <  0 = illegalBufferSize handle "hPutBuf" count+  | otherwise = +    wantWritableHandle "hPutBuf" handle $ +      \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> +          bufWrite fd ref is_stream ptr count can_block++bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int+bufWrite fd ref is_stream ptr count can_block =+  seq count $ seq fd $ do  -- strictness hack+  old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }+     <- readIORef ref++  -- enough room in handle buffer?+  if (size - w > count)+        -- There's enough room in the buffer:+        -- just copy the data in and update bufWPtr.+        then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)+                writeIORef ref old_buf{ bufWPtr = w + count }+                return count++        -- else, we have to flush+        else do flushed_buf <- flushWriteBuffer fd is_stream old_buf+                        -- TODO: we should do a non-blocking flush here+                writeIORef ref flushed_buf+                -- if we can fit in the buffer, then just loop  +                if count < size+                   then bufWrite fd ref is_stream ptr count can_block+                   else if can_block+                           then do writeChunk fd is_stream (castPtr ptr) count+                                   return count+                           else writeChunkNonBlocking fd is_stream ptr count++writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()+writeChunk fd is_stream ptr bytes0 = loop 0 bytes0+ where+  loop :: Int -> Int -> IO ()+  loop _   bytes | bytes <= 0 = return ()+  loop off bytes = do+    r <- fromIntegral `liftM`+           writeRawBufferPtr "writeChunk" fd is_stream ptr+                             off (fromIntegral bytes)+    -- write can't return 0+    loop (off + r) (bytes - r)++writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int+writeChunkNonBlocking fd+#ifndef mingw32_HOST_OS+                         _+#else+                         is_stream+#endif+                                   ptr bytes0 = loop 0 bytes0+ where+  loop :: Int -> Int -> IO Int+  loop off bytes | bytes <= 0 = return off+  loop off bytes = do+#ifndef mingw32_HOST_OS+    ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)+    let r = fromIntegral ssize :: Int+    if (r == -1)+      then do errno <- getErrno+              if (errno == eAGAIN || errno == eWOULDBLOCK)+                 then return off+                 else throwErrno "writeChunk"+      else loop (off + r) (bytes - r)+#else+    (ssize, rc) <- asyncWrite (fromIntegral fd)+                              (fromIntegral $ fromEnum is_stream)+                                 (fromIntegral bytes)+                                 (ptr `plusPtr` off)+    let r = fromIntegral ssize :: Int+    if r == (-1)+      then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)+      else loop (off + r) (bytes - r)+#endif++-- ---------------------------------------------------------------------------+-- hGetBuf++-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@+-- into the buffer @buf@ until either EOF is reached or+-- @count@ 8-bit bytes have been read.+-- It returns the number of bytes actually read.  This may be zero if+-- EOF was reached before any data was read (or if @count@ is zero).+--+-- 'hGetBuf' never raises an EOF exception, instead it returns a value+-- smaller than @count@.+--+-- If the handle is a pipe or socket, and the writing end+-- is closed, 'hGetBuf' will behave as if EOF was reached.++hGetBuf :: Handle -> Ptr a -> Int -> IO Int+hGetBuf h ptr count+  | count == 0 = return 0+  | count <  0 = illegalBufferSize h "hGetBuf" count+  | otherwise = +      wantReadableHandle "hGetBuf" h $ +        \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do+            bufRead fd ref is_stream ptr 0 count++-- small reads go through the buffer, large reads are satisfied by+-- taking data first from the buffer and then direct from the file+-- descriptor.+bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int+bufRead fd ref is_stream ptr so_far count =+  seq fd $ seq so_far $ seq count $ do -- strictness hack+  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref+  if bufferEmpty buf+     then if count > sz  -- small read?+                then do rest <- readChunk fd is_stream ptr count+                        return (so_far + rest)+                else do mb_buf <- maybeFillReadBuffer fd True is_stream buf+                        case mb_buf of+                          Nothing -> return so_far -- got nothing, we're done+                          Just buf' -> do+                                writeIORef ref buf'+                                bufRead fd ref is_stream ptr so_far count+     else do +        let avail = w - r+        if (count == avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+                return (so_far + count)+           else do+        if (count < avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufRPtr = r + count }+                return (so_far + count)+           else do+  +        memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)+        writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+        let remaining = count - avail+            so_far' = so_far + avail+            ptr' = ptr `plusPtr` avail++        if remaining < sz+           then bufRead fd ref is_stream ptr' so_far' remaining+           else do ++        rest <- readChunk fd is_stream ptr' remaining+        return (so_far' + rest)++readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int+readChunk fd is_stream ptr bytes0 = loop 0 bytes0+ where+  loop :: Int -> Int -> IO Int+  loop off bytes | bytes <= 0 = return off+  loop off bytes = do+    r <- fromIntegral `liftM`+           readRawBufferPtr "readChunk" fd is_stream +                            (castPtr ptr) off (fromIntegral bytes)+    if r == 0+        then return off+        else loop (off + r) (bytes - r)+++-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@+-- into the buffer @buf@ until either EOF is reached, or+-- @count@ 8-bit bytes have been read, or there is no more data available+-- to read immediately.+--+-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will+-- never block waiting for data to become available, instead it returns+-- only whatever data is available.  To wait for data to arrive before+-- calling 'hGetBufNonBlocking', use 'hWaitForInput'.+--+-- If the handle is a pipe or socket, and the writing end+-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.+--+hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int+hGetBufNonBlocking h ptr count+  | count == 0 = return 0+  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count+  | otherwise = +      wantReadableHandle "hGetBufNonBlocking" h $ +        \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do+            bufReadNonBlocking fd ref is_stream ptr 0 count++bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int+                   -> IO Int+bufReadNonBlocking fd ref is_stream ptr so_far count =+  seq fd $ seq so_far $ seq count $ do -- strictness hack+  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref+  if bufferEmpty buf+     then if count > sz  -- large read?+                then do rest <- readChunkNonBlocking fd is_stream ptr count+                        return (so_far + rest)+                else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf+                        case buf' of { Buffer{ bufWPtr=w' }  ->+                        if (w' == 0) +                           then return so_far+                           else do writeIORef ref buf'+                                   bufReadNonBlocking fd ref is_stream ptr+                                         so_far (min count w')+                                  -- NOTE: new count is    min count w'+                                  -- so we will just copy the contents of the+                                  -- buffer in the recursive call, and not+                                  -- loop again.+                        }+     else do+        let avail = w - r+        if (count == avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+                return (so_far + count)+           else do+        if (count < avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufRPtr = r + count }+                return (so_far + count)+           else do++        memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)+        writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+        let remaining = count - avail+            so_far' = so_far + avail+            ptr' = ptr `plusPtr` avail++        -- we haven't attempted to read anything yet if we get to here.+        if remaining < sz+           then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining+           else do ++        rest <- readChunkNonBlocking fd is_stream ptr' remaining+        return (so_far' + rest)+++readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int+readChunkNonBlocking fd is_stream ptr bytes = do+    fromIntegral `liftM`+        readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream +                            (castPtr ptr) 0 (fromIntegral bytes)++    -- we don't have non-blocking read support on Windows, so just invoke+    -- the ordinary low-level read which will block until data is available,+    -- but won't wait for the whole buffer to fill.++slurpFile :: FilePath -> IO (Ptr (), Int)+slurpFile fname = do+  handle <- openFile fname ReadMode+  sz     <- hFileSize handle+  if sz > fromIntegral (maxBound::Int) then +    ioError (userError "slurpFile: file too big")+   else do+    let sz_i = fromIntegral sz+    if sz_i == 0 then return (nullPtr, 0) else do+    chunk <- mallocBytes sz_i+    r <- hGetBuf handle chunk sz_i+    hClose handle+    return (chunk, r)++-- ---------------------------------------------------------------------------+-- memcpy wrappers++foreign import ccall unsafe "__hscore_memcpy_src_off"+   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())+foreign import ccall unsafe "__hscore_memcpy_src_off"+   memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())+foreign import ccall unsafe "__hscore_memcpy_dst_off"+   memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())+foreign import ccall unsafe "__hscore_memcpy_dst_off"+   memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())++-----------------------------------------------------------------------------+-- Internal Utils++illegalBufferSize :: Handle -> String -> Int -> IO a+illegalBufferSize handle fn sz =+        ioException (IOError (Just handle)+                            InvalidArgument  fn+                            ("illegal buffer size " ++ showsPrec 9 sz [])+                            Nothing)
+ lib/base/src/GHC/IOBase.lhs view
@@ -0,0 +1,1046 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.IOBase+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Definitions for the 'IO' monad and its friends.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.IOBase(+    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, +    unsafePerformIO, unsafeInterleaveIO,+    unsafeDupablePerformIO, unsafeDupableInterleaveIO,+    noDuplicate,++        -- To and from from ST+    stToIO, ioToST, unsafeIOToST, unsafeSTToIO,++        -- References+    IORef(..), newIORef, readIORef, writeIORef, +    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, +    unsafeWriteIOArray, boundsIOArray,+    MVar(..),++        -- Handles, file descriptors,+    FilePath,  +    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, +    isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,++        -- Buffers+    Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),+    bufferIsWritable, bufferEmpty, bufferFull, ++        -- Exceptions+    Exception(..), {-ArithException(..),-} AsyncException(..), ArrayException(..),+    --stackOverflow, heapOverflow,+    ioException, +    IOError, IOException(..), IOErrorType(..), ioError, userError,+    ExitCode(..),+    throwIO, block, unblock, blocked, catchAny, catchException,+    evaluate,+    {-ErrorCall(..), -}AssertionFailed(..), assertError, untangle,+    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),+    --blockedOnDeadMVar, blockedIndefinitely+  ) where++import GHC.ST+import GHC.Arr  -- to derive Ix class+import GHC.Enum -- to derive Enum class+import GHC.STRef+import GHC.Base+--  import GHC.Num      -- To get fromInteger etc, needed because of -XNoImplicitPrelude+import Data.Maybe  ( Maybe(..) )+import GHC.Show+import GHC.List+import GHC.Read+import Foreign.C.Types (CInt)+import GHC.Exception++#ifndef __HADDOCK__+import {-# SOURCE #-} Data.Typeable     ( Typeable )+#endif++-- ---------------------------------------------------------------------------+-- The IO Monad++{-+The IO Monad is just an instance of the ST monad, where the state is+the real world.  We use the exception mechanism (in GHC.Exception) to+implement IO exceptions.++NOTE: The IO representation is deeply wired in to various parts of the+system.  The following list may or may not be exhaustive:++Compiler  - types of various primitives in PrimOp.lhs++RTS       - forceIO (StgMiscClosures.hc)+          - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast +            (Exceptions.hc)+          - raiseAsync (Schedule.c)++Prelude   - GHC.IOBase.lhs, and several other places including+            GHC.Exception.lhs.++Libraries - parts of hslibs/lang.++--SDM+-}++{-|+A value of type @'IO' a@ is a computation which, when performed,+does some I\/O before returning a value of type @a@.  ++There is really only one way to \"perform\" an I\/O action: bind it to+@Main.main@ in your program.  When your program is run, the I\/O will+be performed.  It isn't possible to perform I\/O from an arbitrary+function, unless that function is itself in the 'IO' monad and called+at some point, directly or indirectly, from @Main.main@.++'IO' is a monad, so 'IO' actions can be combined using either the do-notation+or the '>>' and '>>=' operations from the 'Monad' class.+-}+newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))++unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))+unIO (IO a) = a++instance  Functor IO where+   fmap f x = x >>= (return . f)++instance  Monad IO  where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    m >> k      =  m >>= \ _ -> k+    return x    = returnIO x++    m >>= k     = bindIO m k+    fail s      = failIO s++failIO :: String -> IO a+failIO s = ioError (userError s)++liftIO :: IO a -> State# RealWorld -> STret RealWorld a+liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r++bindIO :: IO a -> (a -> IO b) -> IO b+bindIO (IO m) k = IO ( \ s ->+  case m s of +    (# new_s, a #) -> unIO (k a) new_s+  )++thenIO :: IO a -> IO b -> IO b+thenIO (IO m) k = IO ( \ s ->+  case m s of +    (# new_s, _ #) -> unIO k new_s+  )++returnIO :: a -> IO a+returnIO x = IO (\ s -> (# s, x #))++-- ---------------------------------------------------------------------------+-- Coercions between IO and ST++-- | A monad transformer embedding strict state transformers in the 'IO'+-- monad.  The 'RealWorld' parameter indicates that the internal state+-- used by the 'ST' computation is a special one supplied by the 'IO'+-- monad, and thus distinct from those used by invocations of 'runST'.+stToIO        :: ST RealWorld a -> IO a+stToIO (ST m) = IO m++ioToST        :: IO a -> ST RealWorld a+ioToST (IO m) = (ST m)++-- This relies on IO and ST having the same representation modulo the+-- constraint on the type of the state+--+unsafeIOToST        :: IO a -> ST s a+unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s++unsafeSTToIO :: ST s a -> IO a+unsafeSTToIO (ST m) = IO (unsafeCoerce# m)++-- ---------------------------------------------------------------------------+-- Unsafe IO operations++{-|+This is the \"back door\" into the 'IO' monad, allowing+'IO' computation to be performed at any time.  For+this to be safe, the 'IO' computation should be+free of side effects and independent of its environment.++If the I\/O computation wrapped in 'unsafePerformIO'+performs side effects, then the relative order in which those side+effects take place (relative to the main I\/O trunk, or other calls to+'unsafePerformIO') is indeterminate.  You have to be careful when +writing and compiling modules that use 'unsafePerformIO':++  * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@+        that calls 'unsafePerformIO'.  If the call is inlined,+        the I\/O may be performed more than once.++  * Use the compiler flag @-fno-cse@ to prevent common sub-expression+        elimination being performed on the module, which might combine+        two side effects that were meant to be separate.  A good example+        is using multiple global variables (like @test@ in the example below).++  * Make sure that the either you switch off let-floating, or that the +        call to 'unsafePerformIO' cannot float outside a lambda.  For example, +        if you say:+        @+           f x = unsafePerformIO (newIORef [])+        @+        you may get only one reference cell shared between all calls to @f@.+        Better would be+        @+           f x = unsafePerformIO (newIORef [x])+        @+        because now it can't float outside the lambda.++It is less well known that+'unsafePerformIO' is not type safe.  For example:++>     test :: IORef [a]+>     test = unsafePerformIO $ newIORef []+>     +>     main = do+>             writeIORef test [42]+>             bang <- readIORef test+>             print (bang :: [Char])++This program will core dump.  This problem with polymorphic references+is well known in the ML community, and does not arise with normal+monadic use of references.  There is no easy way to make it impossible+once you use 'unsafePerformIO'.  Indeed, it is+possible to write @coerce :: a -> b@ with the+help of 'unsafePerformIO'.  So be careful!+-}+unsafePerformIO :: IO a -> a+unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)++{-| +This version of 'unsafePerformIO' is slightly more efficient,+because it omits the check that the IO is only being performed by a+single thread.  Hence, when you write 'unsafeDupablePerformIO',+there is a possibility that the IO action may be performed multiple+times (on a multiprocessor), and you should therefore ensure that+it gives the same results each time.+-}+{-# NOINLINE unsafeDupablePerformIO #-}+unsafeDupablePerformIO  :: IO a -> a+unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)++-- Why do we NOINLINE unsafeDupablePerformIO?  See the comment with+-- GHC.ST.runST.  Essentially the issue is that the IO computation+-- inside unsafePerformIO must be atomic: it must either all run, or+-- not at all.  If we let the compiler see the application of the IO+-- to realWorld#, it might float out part of the IO.++-- Why is there a call to 'lazy' in unsafeDupablePerformIO?+-- If we don't have it, the demand analyser discovers the following strictness+-- for unsafeDupablePerformIO:  C(U(AV))+-- But then consider+--      unsafeDupablePerformIO (\s -> let r = f x in +--                             case writeIORef v r s of (# s1, _ #) ->+--                             (# s1, r #)+-- The strictness analyser will find that the binding for r is strict,+-- (becuase of uPIO's strictness sig), and so it'll evaluate it before +-- doing the writeIORef.  This actually makes tests/lib/should_run/memo002+-- get a deadlock!  +--+-- Solution: don't expose the strictness of unsafeDupablePerformIO,+--           by hiding it with 'lazy'++{-|+'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.+When passed a value of type @IO a@, the 'IO' will only be performed+when the value of the @a@ is demanded.  This is used to implement lazy+file reading, see 'System.IO.hGetContents'.+-}+{-# INLINE unsafeInterleaveIO #-}+unsafeInterleaveIO :: IO a -> IO a+unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)++-- We believe that INLINE on unsafeInterleaveIO is safe, because the+-- state from this IO thread is passed explicitly to the interleaved+-- IO, so it cannot be floated out and shared.++{-# INLINE unsafeDupableInterleaveIO #-}+unsafeDupableInterleaveIO :: IO a -> IO a+unsafeDupableInterleaveIO (IO m)+  = IO ( \ s -> let+                   r = case m s of (# _, res #) -> res+                in+                (# s, r #))++{-| +Ensures that the suspensions under evaluation by the current thread+are unique; that is, the current thread is not evaluating anything+that is also under evaluation by another thread that has also executed+'noDuplicate'.++This operation is used in the definition of 'unsafePerformIO' to+prevent the IO action from being executed multiple times, which is usually+undesirable.+-}+noDuplicate :: IO ()+noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)++-- ---------------------------------------------------------------------------+-- Handle type++data MVar a = MVar (MVar# RealWorld a)+{- ^+An 'MVar' (pronounced \"em-var\") is a synchronising variable, used+for communication between concurrent threads.  It can be thought of+as a a box, which may be empty or full.+-}++-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module+instance Eq (MVar a) where+        (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#++--  A Handle is represented by (a reference to) a record +--  containing the state of the I/O port/device. We record+--  the following pieces of info:++--    * type (read,write,closed etc.)+--    * the underlying file descriptor+--    * buffering mode +--    * buffer, and spare buffers+--    * user-friendly name (usually the+--      FilePath used when IO.openFile was called)++-- Note: when a Handle is garbage collected, we want to flush its buffer+-- and close the OS file handle, so as to free up a (precious) resource.++-- | Haskell defines operations to read and write characters from and to files,+-- represented by values of type @Handle@.  Each value of this type is a+-- /handle/: a record used by the Haskell run-time system to /manage/ I\/O+-- with file system objects.  A handle has at least the following properties:+-- +--  * whether it manages input or output or both;+--+--  * whether it is /open/, /closed/ or /semi-closed/;+--+--  * whether the object is seekable;+--+--  * whether buffering is disabled, or enabled on a line or block basis;+--+--  * a buffer (whose length may be zero).+--+-- Most handles will also have a current I\/O position indicating where the next+-- input or output operation will occur.  A handle is /readable/ if it+-- manages only input or both input and output; likewise, it is /writable/ if+-- it manages only output or both input and output.  A handle is /open/ when+-- first allocated.+-- Once it is closed it can no longer be used for either input or output,+-- though an implementation cannot re-use its storage while references+-- remain to it.  Handles are in the 'Show' and 'Eq' classes.  The string+-- produced by showing a handle is system dependent; it should include+-- enough information to identify the handle for debugging.  A handle is+-- equal according to '==' only to itself; no attempt+-- is made to compare the internal state of different handles for equality.+--+-- GHC note: a 'Handle' will be automatically closed when the garbage+-- collector detects that it has become unreferenced by the program.+-- However, relying on this behaviour is not generally recommended:+-- the garbage collector is unpredictable.  If possible, use explicit+-- an explicit 'hClose' to close 'Handle's when they are no longer+-- required.  GHC does not currently attempt to free up file+-- descriptors when they have run out, it is your responsibility to+-- ensure that this doesn't happen.++data Handle +  = FileHandle                          -- A normal handle to a file+        FilePath                        -- the file (invariant)+        !(MVar Handle__)++  | DuplexHandle                        -- A handle to a read/write stream+        FilePath                        -- file for a FIFO, otherwise some+                                        --   descriptive string.+        !(MVar Handle__)                -- The read side+        !(MVar Handle__)                -- The write side++-- NOTES:+--    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be+--      seekable.++instance Eq Handle where+ (FileHandle _ h1)     == (FileHandle _ h2)     = h1 == h2+ (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2+ _ == _ = False ++type FD = CInt++data Handle__+  = Handle__ {+      haFD          :: !FD,                  -- file descriptor+      haType        :: HandleType,           -- type (read/write/append etc.)+      haIsBin       :: Bool,                 -- binary mode?+      haIsStream    :: Bool,                 -- Windows : is this a socket?+                                             -- Unix    : is O_NONBLOCK set?+      haBufferMode  :: BufferMode,           -- buffer contains read/write data?+      haBuffer      :: !(IORef Buffer),      -- the current buffer+      haBuffers     :: !(IORef BufferList),  -- spare buffers+      haOtherSide   :: Maybe (MVar Handle__) -- ptr to the write side of a +                                             -- duplex handle.+    }++-- ---------------------------------------------------------------------------+-- Buffers++-- The buffer is represented by a mutable variable containing a+-- record, where the record contains the raw buffer and the start/end+-- points of the filled portion.  We use a mutable variable so that+-- the common operation of writing (or reading) some data from (to)+-- the buffer doesn't need to modify, and hence copy, the handle+-- itself, it just updates the buffer.  ++-- There will be some allocation involved in a simple hPutChar in+-- order to create the new Buffer structure (below), but this is+-- relatively small, and this only has to be done once per write+-- operation.++-- The buffer contains its size - we could also get the size by+-- calling sizeOfMutableByteArray# on the raw buffer, but that tends+-- to be rounded up to the nearest Word.++type RawBuffer = MutableByteArray# RealWorld++-- INVARIANTS on a Buffer:+--+--   * A handle *always* has a buffer, even if it is only 1 character long+--     (an unbuffered handle needs a 1 character buffer in order to support+--      hLookAhead and hIsEOF).+--   * r <= w+--   * if r == w, then r == 0 && w == 0+--   * if state == WriteBuffer, then r == 0+--   * a write buffer is never full.  If an operation+--     fills up the buffer, it will always flush it before +--     returning.+--   * a read buffer may be full as a result of hLookAhead.  In normal+--     operation, a read buffer always has at least one character of space.++data Buffer +  = Buffer {+        bufBuf   :: RawBuffer,+        bufRPtr  :: !Int,+        bufWPtr  :: !Int,+        bufSize  :: !Int,+        bufState :: BufferState+  }++data BufferState = ReadBuffer | WriteBuffer deriving (Eq)++-- we keep a few spare buffers around in a handle to avoid allocating+-- a new one for each hPutStr.  These buffers are *guaranteed* to be the+-- same size as the main buffer.+data BufferList +  = BufferListNil +  | BufferListCons RawBuffer BufferList+++bufferIsWritable :: Buffer -> Bool+bufferIsWritable Buffer{ bufState=WriteBuffer } = True+bufferIsWritable _other = False++bufferEmpty :: Buffer -> Bool+bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w++-- only makes sense for a write buffer+bufferFull :: Buffer -> Bool+bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b++--  Internally, we classify handles as being one+--  of the following:++data HandleType+ = ClosedHandle+ | SemiClosedHandle+ | ReadHandle+ | WriteHandle+ | AppendHandle+ | ReadWriteHandle++isReadableHandleType :: HandleType -> Bool+isReadableHandleType ReadHandle         = True+isReadableHandleType ReadWriteHandle    = True+isReadableHandleType _                  = False++isWritableHandleType :: HandleType -> Bool+isWritableHandleType AppendHandle    = True+isWritableHandleType WriteHandle     = True+isWritableHandleType ReadWriteHandle = True+isWritableHandleType _               = False++isReadWriteHandleType :: HandleType -> Bool+isReadWriteHandleType ReadWriteHandle{} = True+isReadWriteHandleType _                 = False++-- | File and directory names are values of type 'String', whose precise+-- meaning is operating system dependent. Files can be opened, yielding a+-- handle which can then be used to operate on the contents of that file.++type FilePath = String++-- ---------------------------------------------------------------------------+-- Buffering modes++-- | Three kinds of buffering are supported: line-buffering, +-- block-buffering or no-buffering.  These modes have the following+-- effects. For output, items are written out, or /flushed/,+-- from the internal buffer according to the buffer mode:+--+--  * /line-buffering/: the entire output buffer is flushed+--    whenever a newline is output, the buffer overflows, +--    a 'System.IO.hFlush' is issued, or the handle is closed.+--+--  * /block-buffering/: the entire buffer is written out whenever it+--    overflows, a 'System.IO.hFlush' is issued, or the handle is closed.+--+--  * /no-buffering/: output is written immediately, and never stored+--    in the buffer.+--+-- An implementation is free to flush the buffer more frequently,+-- but not less frequently, than specified above.+-- The output buffer is emptied as soon as it has been written out.+--+-- Similarly, input occurs according to the buffer mode for the handle:+--+--  * /line-buffering/: when the buffer for the handle is not empty,+--    the next item is obtained from the buffer; otherwise, when the+--    buffer is empty, characters up to and including the next newline+--    character are read into the buffer.  No characters are available+--    until the newline character is available or the buffer is full.+--+--  * /block-buffering/: when the buffer for the handle becomes empty,+--    the next block of data is read into the buffer.+--+--  * /no-buffering/: the next input item is read and returned.+--    The 'System.IO.hLookAhead' operation implies that even a no-buffered+--    handle may require a one-character buffer.+--+-- The default buffering mode when a handle is opened is+-- implementation-dependent and may depend on the file system object+-- which is attached to that handle.+-- For most implementations, physical files will normally be block-buffered +-- and terminals will normally be line-buffered.++data BufferMode  + = NoBuffering  -- ^ buffering is disabled if possible.+ | LineBuffering+                -- ^ line-buffering should be enabled if possible.+ | BlockBuffering (Maybe Int)+                -- ^ block-buffering should be enabled if possible.+                -- The size of the buffer is @n@ items if the argument+                -- is 'Just' @n@ and is otherwise implementation-dependent.+--   deriving (Eq, Ord, Read, Show)+   deriving (Eq, Ord, Show)++-- ---------------------------------------------------------------------------+-- IORefs++-- |A mutable variable in the 'IO' monad+newtype IORef a = IORef (STRef RealWorld a)++-- explicit instance because Haddock can't figure out a derived one+instance Eq (IORef a) where+  IORef x == IORef y = x == y++-- |Build a new 'IORef'+newIORef    :: a -> IO (IORef a)+newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)++-- |Read the value of an 'IORef'+readIORef   :: IORef a -> IO a+readIORef  (IORef var) = stToIO (readSTRef var)++-- |Write a new value into an 'IORef'+writeIORef  :: IORef a -> a -> IO ()+writeIORef (IORef var) v = stToIO (writeSTRef var v)++-- ---------------------------------------------------------------------------+-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad.  +-- The type arguments are as follows:+--+--  * @i@: the index type of the array (should be an instance of 'Ix')+--+--  * @e@: the element type of the array.+--+-- ++newtype IOArray i e = IOArray (STArray RealWorld i e)++-- explicit instance because Haddock can't figure out a derived one+instance Eq (IOArray i e) where+  IOArray x == IOArray y = x == y++-- |Build a new 'IOArray'+newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)+{-# INLINE newIOArray #-}+newIOArray lu initial  = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)}++-- | Read a value from an 'IOArray'+unsafeReadIOArray  :: Ix i => IOArray i e -> Int -> IO e+{-# INLINE unsafeReadIOArray #-}+unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i)++-- | Write a new value into an 'IOArray'+unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO ()+{-# INLINE unsafeWriteIOArray #-}+unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e)++-- | Read a value from an 'IOArray'+readIOArray  :: Ix i => IOArray i e -> i -> IO e+readIOArray (IOArray marr) i = stToIO (readSTArray marr i)++-- | Write a new value into an 'IOArray'+writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()+writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)++{-# INLINE boundsIOArray #-}+boundsIOArray :: IOArray i e -> (i,i)  +boundsIOArray (IOArray marr) = boundsSTArray marr++-- ---------------------------------------------------------------------------+-- Show instance for Handles++-- handle types are 'show'n when printing error msgs, so+-- we provide a more user-friendly Show instance for it+-- than the derived one.++instance Show HandleType where+  showsPrec _ t =+    case t of+      ClosedHandle      -> showString "closed"+      SemiClosedHandle  -> showString "semi-closed"+      ReadHandle        -> showString "readable"+      WriteHandle       -> showString "writable"+      AppendHandle      -> showString "writable (append)"+      ReadWriteHandle   -> showString "read-writable"++instance Show Handle where +  showsPrec _ (FileHandle   file _)   = showHandle file+  showsPrec _ (DuplexHandle file _ _) = showHandle file++showHandle :: FilePath -> String -> String+showHandle file = showString "{handle: " . showString file . showString "}"++-- ------------------------------------------------------------------------+-- Exception datatypes and operations++-- |The thread is blocked on an @MVar@, but there are no other references+-- to the @MVar@ so it can't ever continue.+data BlockedOnDeadMVar = BlockedOnDeadMVar+    deriving Typeable++instance Exception BlockedOnDeadMVar++instance Show BlockedOnDeadMVar where+    showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"++--blockedOnDeadMVar :: SomeException -- for the RTS+--blockedOnDeadMVar = toException BlockedOnDeadMVar++-----++-- |The thread is awiting to retry an STM transaction, but there are no+-- other references to any @TVar@s involved, so it can't ever continue.+data BlockedIndefinitely = BlockedIndefinitely+    deriving Typeable++instance Exception BlockedIndefinitely++instance Show BlockedIndefinitely where+    showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"++--blockedIndefinitely :: SomeException -- for the RTS+--blockedIndefinitely = toException BlockedIndefinitely++-----++-- |There are no runnable threads, so the program is deadlocked.+-- The @Deadlock@ exception is raised in the main thread only.+data Deadlock = Deadlock+    deriving Typeable++instance Exception Deadlock++instance Show Deadlock where+    showsPrec _ Deadlock = showString "<<deadlock>>"++-----++-- |Exceptions generated by 'assert'. The @String@ gives information+-- about the source location of the assertion.+data AssertionFailed = AssertionFailed String+    deriving Typeable++instance Exception AssertionFailed++instance Show AssertionFailed where+    showsPrec _ (AssertionFailed err) = showString err++-----++-- |Asynchronous exceptions.+data AsyncException+  = StackOverflow+        -- ^The current thread\'s stack exceeded its limit.+        -- Since an exception has been raised, the thread\'s stack+        -- will certainly be below its limit again, but the+        -- programmer should take remedial action+        -- immediately.+  | HeapOverflow+        -- ^The program\'s heap is reaching its limit, and+        -- the program should take action to reduce the amount of+        -- live data it has. Notes:+        --+        --      * It is undefined which thread receives this exception.+        --+        --      * GHC currently does not throw 'HeapOverflow' exceptions.+  | ThreadKilled+        -- ^This exception is raised by another thread+        -- calling 'Control.Concurrent.killThread', or by the system+        -- if it needs to terminate the thread for some+        -- reason.+  | UserInterrupt+        -- ^This exception is raised by default in the main thread of+        -- the program when the user requests to terminate the program+        -- via the usual mechanism(s) (e.g. Control-C in the console).+  deriving (Eq, Ord, Typeable)++instance Exception AsyncException++-- | Exceptions generated by array operations+data ArrayException+  = IndexOutOfBounds    String+        -- ^An attempt was made to index an array outside+        -- its declared bounds.+  | UndefinedElement    String+        -- ^An attempt was made to evaluate an element of an+        -- array that had not been initialized.+  deriving (Eq, Ord, Typeable)++instance Exception ArrayException++--stackOverflow, heapOverflow :: SomeException -- for the RTS+--stackOverflow = toException StackOverflow+--heapOverflow  = toException HeapOverflow++instance Show AsyncException where+  showsPrec _ StackOverflow   = showString "stack overflow"+  showsPrec _ HeapOverflow    = showString "heap overflow"+  showsPrec _ ThreadKilled    = showString "thread killed"+  showsPrec _ UserInterrupt   = showString "user interrupt"++instance Show ArrayException where+  showsPrec _ (IndexOutOfBounds s)+        = showString "array index out of range"+        . (if not (null s) then showString ": " . showString s+                           else id)+  showsPrec _ (UndefinedElement s)+        = showString "undefined array element"+        . (if not (null s) then showString ": " . showString s+                           else id)++-- -----------------------------------------------------------------------------+-- The ExitCode type++-- We need it here because it is used in ExitException in the+-- Exception datatype (above).++data ExitCode+  = ExitSuccess -- ^ indicates successful termination;+  | ExitFailure Int+                -- ^ indicates program failure with an exit code.+                -- The exact interpretation of the code is+                -- operating-system dependent.  In particular, some values+                -- may be prohibited (e.g. 0 on a POSIX-compliant system).+  deriving (Eq, Ord, Read, Show, Typeable)++instance Exception ExitCode++ioException     :: IOException -> IO a+ioException err = throwIO err++-- | Raise an 'IOError' in the 'IO' monad.+ioError         :: IOError -> IO a +ioError         =  ioException++-- ---------------------------------------------------------------------------+-- IOError type++-- | The Haskell 98 type for exceptions in the 'IO' monad.+-- Any I\/O operation may raise an 'IOError' instead of returning a result.+-- For a more general type of exception, including also those that arise+-- in pure code, see 'Control.Exception.Exception'.+--+-- In Haskell 98, this is an opaque type.+type IOError = IOException++-- |Exceptions that occur in the @IO@ monad.+-- An @IOException@ records a more specific error type, a descriptive+-- string and maybe the handle that was used when the error was+-- flagged.+data IOException+ = IOError {+     ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging +                                     -- the error.+     ioe_type     :: IOErrorType,    -- what it was.+     ioe_location :: String,         -- location.+     ioe_description :: String,      -- error type specific information.+     ioe_filename :: Maybe FilePath  -- filename the error is related to.+   }+    deriving Typeable++instance Exception IOException++instance Eq IOException where+  (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = +    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2++-- | An abstract type that contains a value for each variant of 'IOError'.+data IOErrorType+  -- Haskell 98:+  = AlreadyExists+  | NoSuchThing+  | ResourceBusy+  | ResourceExhausted+  | EOF+  | IllegalOperation+  | PermissionDenied+  | UserError+  -- GHC only:+  | UnsatisfiedConstraints+  | SystemError+  | ProtocolError+  | OtherError+  | InvalidArgument+  | InappropriateType+  | HardwareFault+  | UnsupportedOperation+  | TimeExpired+  | ResourceVanished+  | Interrupted++instance Eq IOErrorType where+   x == y = getTag x ==# getTag y+ +instance Show IOErrorType where+  showsPrec _ e =+    showString $+    case e of+      AlreadyExists     -> "already exists"+      NoSuchThing       -> "does not exist"+      ResourceBusy      -> "resource busy"+      ResourceExhausted -> "resource exhausted"+      EOF               -> "end of file"+      IllegalOperation  -> "illegal operation"+      PermissionDenied  -> "permission denied"+      UserError         -> "user error"+      HardwareFault     -> "hardware fault"+      InappropriateType -> "inappropriate type"+      Interrupted       -> "interrupted"+      InvalidArgument   -> "invalid argument"+      OtherError        -> "failed"+      ProtocolError     -> "protocol error"+      ResourceVanished  -> "resource vanished"+      SystemError       -> "system error"+      TimeExpired       -> "timeout"+      UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!+      UnsupportedOperation -> "unsupported operation"++-- | Construct an 'IOError' value with a string describing the error.+-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a+-- 'userError', thus:+--+-- > instance Monad IO where +-- >   ...+-- >   fail s = ioError (userError s)+--+userError       :: String  -> IOError+userError str   =  IOError Nothing UserError "" str Nothing++-- ---------------------------------------------------------------------------+-- Showing IOErrors++instance Show IOException where+    showsPrec p (IOError hdl iot loc s fn) =+      (case fn of+         Nothing -> case hdl of+                        Nothing -> id+                        Just h  -> showsPrec p h . showString ": "+         Just name -> showString name . showString ": ") .+      (case loc of+         "" -> id+         _  -> showString loc . showString ": ") .+      showsPrec p iot . +      (case s of+         "" -> id+         _  -> showString " (" . showString s . showString ")")++-- -----------------------------------------------------------------------------+-- IOMode type++data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode+                    deriving (Eq, Ord, Ix, Enum, Read, Show)+\end{code}++%*********************************************************+%*                                                      *+\subsection{Primitive catch and throwIO}+%*                                                      *+%*********************************************************++catchException used to handle the passing around of the state to the+action and the handler.  This turned out to be a bad idea - it meant+that we had to wrap both arguments in thunks so they could be entered+as normal (remember IO returns an unboxed pair...).++Now catch# has type++    catch# :: IO a -> (b -> IO a) -> IO a++(well almost; the compiler doesn't know about the IO newtype so we+have to work around that in the definition of catchException below).++\begin{code}++catchException :: Exception e => IO a -> (e -> IO a) -> IO a+catchException io handler = io{-+catchException (IO io) handler = IO $ catch# io handler'+    where handler' e = case fromException e of+                       Just e' -> unIO (handler e')+                       Nothing -> raise# e-}++catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a+catchAny io handler = io{-+catchAny (IO io) handler = IO $ catch# io handler'+    where handler' (SomeException e) = unIO (handler e)-}++-- | A variant of 'throw' that can only be used within the 'IO' monad.+--+-- Although 'throwIO' has a type that is an instance of the type of 'throw', the+-- two functions are subtly different:+--+-- > throw e   `seq` x  ===> throw e+-- > throwIO e `seq` x  ===> x+--+-- The first example will cause the exception @e@ to be raised,+-- whereas the second one won\'t.  In fact, 'throwIO' will only cause+-- an exception to be raised when it is used within the 'IO' monad.+-- The 'throwIO' variant should be used in preference to 'throw' to+-- raise an exception within the 'IO' monad because it guarantees+-- ordering with respect to other 'IO' operations, whereas 'throw'+-- does not.+throwIO :: Exception e => e -> IO a+throwIO e = IO (raiseIO# (toException e))++\end{code}+++%*********************************************************+%*                                                      *+\subsection{Controlling asynchronous exception delivery}+%*                                                      *+%*********************************************************++\begin{code}+-- | Applying 'block' to a computation will+-- execute that computation with asynchronous exceptions+-- /blocked/.  That is, any thread which+-- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be+-- blocked until asynchronous exceptions are enabled again.  There\'s+-- no need to worry about re-enabling asynchronous exceptions; that is+-- done automatically on exiting the scope of+-- 'block'.+--+-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked+-- state from the parent; that is, to start a thread in blocked mode,+-- use @block $ forkIO ...@.  This is particularly useful if you need to+-- establish an exception handler in the forked thread before any+-- asynchronous exceptions are received.+block :: IO a -> IO a++-- | To re-enable asynchronous exceptions inside the scope of+-- 'block', 'unblock' can be+-- used.  It scopes in exactly the same way, so on exit from+-- 'unblock' asynchronous exception delivery will+-- be disabled again.+unblock :: IO a -> IO a++block (IO io) = IO $ blockAsyncExceptions# io+unblock (IO io) = IO $ unblockAsyncExceptions# io++-- | returns True if asynchronous exceptions are blocked in the+-- current thread.+blocked :: IO Bool+blocked = IO $ \s -> case asyncExceptionsBlocked# s of+                        (# s', i #) -> (# s', i /=# 0# #)+\end{code}++\begin{code}+-- | Forces its argument to be evaluated to weak head normal form when+-- the resultant 'IO' action is executed. It can be used to order+-- evaluation with respect to other 'IO' operations; its semantics are+-- given by+--+-- >   evaluate x `seq` y    ==>  y+-- >   evaluate x `catch` f  ==>  (return $! x) `catch` f+-- >   evaluate x >>= f      ==>  (return $! x) >>= f+--+-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the+-- same as @(return $! x)@.  A correct definition is+--+-- >   evaluate x = (return $! x) >>= return+--+evaluate :: a -> IO a+evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)+        -- NB. can't write+        --      a `seq` (# s, a #)+        -- because we can't have an unboxed tuple as a function argument+\end{code}++\begin{code}+assertError :: Addr# -> Bool -> a -> a+assertError str predicate v+  | predicate = v+  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))++{-+(untangle coded message) expects "coded" to be of the form+        "location|details"+It prints+        location message details+-}+untangle :: Addr# -> String -> String+untangle coded message+  =  location+  ++ ": "+  ++ message+  ++ details+  ++ "\n"+  where+    coded_str = unpackCStringUtf8# coded++    (location, details)+      = case (span not_bar coded_str) of { (loc, rest) ->+        case rest of+          ('|':det) -> (loc, ' ' : det)+          _         -> (loc, "")+        }+    not_bar c = c /= '|'+\end{code}+
+ lib/base/src/GHC/Int.hs view
@@ -0,0 +1,809 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Int+-- Copyright   :  (c) The University of Glasgow 1997-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The sized integral datatypes, 'Int8', 'Int16', 'Int32', and 'Int64'.+--+-----------------------------------------------------------------------------++#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#)+#define WORD_SIZE_IN_BITS (WORD_SIZE * 8)++-- #hide+module GHC.Int (+    Int8(..), Int16(..), Int32(..), Int64(..),+    uncheckedIShiftL64#, uncheckedIShiftRA64#+    ) where++import Data.Bits++#if WORD_SIZE < 4+import GHC.IntWord32+#endif+#if WORD_SIZE < 8+import GHC.IntWord64+#endif++import GHC.Base+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Read+import GHC.Arr+import GHC.Word hiding (uncheckedShiftL64#, uncheckedShiftRL64#)+import GHC.Show++------------------------------------------------------------------------+-- type Int8+------------------------------------------------------------------------++-- Int8 is represented in the same way as Int. Operations may assume+-- and must ensure that it holds only values from its logical range.++data Int8 = I8# Int# deriving (Eq, Ord)+-- ^ 8-bit signed integer type++instance Show Int8 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int8 where+    (I8# x#) + (I8# y#)    = I8# (narrow8Int# (x# +# y#))+    (I8# x#) - (I8# y#)    = I8# (narrow8Int# (x# -# y#))+    (I8# x#) * (I8# y#)    = I8# (narrow8Int# (x# *# y#))+    negate (I8# x#)        = I8# (narrow8Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I8# (narrow8Int# (toInt# i))++instance Real Int8 where+    toRational x = toInteger x % 1++instance Enum Int8 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int8"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int8"+    toEnum i@(I# i#)+        | i >= fromIntegral (minBound::Int8) && i <= fromIntegral (maxBound::Int8)+                        = I8# i#+        | otherwise     = toEnumError "Int8" i (minBound::Int8, maxBound::Int8)+    fromEnum (I8# x#)   = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int8 where+    quot    x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `quotInt#` y#))+    rem     x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `remInt#` y#))+    div     x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `divInt#` y#))+    mod     x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `modInt#` y#))+    quotRem x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I8# (narrow8Int# (x# `quotInt#` y#)),+                                       I8# (narrow8Int# (x# `remInt#` y#)))+    divMod  x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I8# (narrow8Int# (x# `divInt#` y#)),+                                       I8# (narrow8Int# (x# `modInt#` y#)))+    toInteger (I8# x#)               = smallInteger x#++instance Bounded Int8 where+    minBound = -0x80+    maxBound =  0x7F++instance Ix Int8 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n++instance Read Int8 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int8 where+    {-# INLINE shift #-}++    (I8# x#) .&.   (I8# y#)   = I8# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I8# x#) .|.   (I8# y#)   = I8# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I8# x#) `xor` (I8# y#)   = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I8# x#)       = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I8# x#) `shift` (I# i#)+        | i# >=# 0#           = I8# (narrow8Int# (x# `iShiftL#` i#))+        | otherwise           = I8# (x# `iShiftRA#` negateInt# i#)+    (I8# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I8# x#+        | otherwise+        = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                       (x'# `uncheckedShiftRL#` (8# -# i'#)))))+        where+        x'# = narrow8Word# (int2Word# x#)+        i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)+    bitSize  _                = 8+    isSigned _                = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8+"fromIntegral/a->Int8"    fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#)+"fromIntegral/Int8->a"    fromIntegral = \(I8# x#) -> fromIntegral (I# x#)+  #-}++------------------------------------------------------------------------+-- type Int16+------------------------------------------------------------------------++-- Int16 is represented in the same way as Int. Operations may assume+-- and must ensure that it holds only values from its logical range.++data Int16 = I16# Int# deriving (Eq, Ord)+-- ^ 16-bit signed integer type++instance Show Int16 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int16 where+    (I16# x#) + (I16# y#)  = I16# (narrow16Int# (x# +# y#))+    (I16# x#) - (I16# y#)  = I16# (narrow16Int# (x# -# y#))+    (I16# x#) * (I16# y#)  = I16# (narrow16Int# (x# *# y#))+    negate (I16# x#)       = I16# (narrow16Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I16# (narrow16Int# (toInt# i))++instance Real Int16 where+    toRational x = toInteger x % 1++instance Enum Int16 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int16"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int16"+    toEnum i@(I# i#)+        | i >= fromIntegral (minBound::Int16) && i <= fromIntegral (maxBound::Int16)+                        = I16# i#+        | otherwise     = toEnumError "Int16" i (minBound::Int16, maxBound::Int16)+    fromEnum (I16# x#)  = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int16 where+    quot    x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `quotInt#` y#))+    rem     x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `remInt#` y#))+    div     x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `divInt#` y#))+    mod     x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `modInt#` y#))+    quotRem x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I16# (narrow16Int# (x# `quotInt#` y#)),+                                        I16# (narrow16Int# (x# `remInt#` y#)))+    divMod  x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I16# (narrow16Int# (x# `divInt#` y#)),+                                        I16# (narrow16Int# (x# `modInt#` y#)))+    toInteger (I16# x#)              = smallInteger x#++instance Bounded Int16 where+    minBound = -0x8000+    maxBound =  0x7FFF++instance Ix Int16 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n++instance Read Int16 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int16 where+    {-# INLINE shift #-}++    (I16# x#) .&.   (I16# y#)  = I16# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I16# x#) .|.   (I16# y#)  = I16# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I16# x#) `xor` (I16# y#)  = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I16# x#)       = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I16# x#) `shift` (I# i#)+        | i# >=# 0#            = I16# (narrow16Int# (x# `iShiftL#` i#))+        | otherwise            = I16# (x# `iShiftRA#` negateInt# i#)+    (I16# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I16# x#+        | otherwise+        = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                         (x'# `uncheckedShiftRL#` (16# -# i'#)))))+        where+        x'# = narrow16Word# (int2Word# x#)+        i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)+    bitSize  _                 = 16+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Int16"  fromIntegral = \(W8# x#) -> I16# (word2Int# x#)+"fromIntegral/Int8->Int16"   fromIntegral = \(I8# x#) -> I16# x#+"fromIntegral/Int16->Int16"  fromIntegral = id :: Int16 -> Int16+"fromIntegral/a->Int16"      fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#)+"fromIntegral/Int16->a"      fromIntegral = \(I16# x#) -> fromIntegral (I# x#)+  #-}++------------------------------------------------------------------------+-- type Int32+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 32++data Int32 = I32# Int32#+-- ^ 32-bit signed integer type++instance Eq Int32 where+    (I32# x#) == (I32# y#) = x# `eqInt32#` y#+    (I32# x#) /= (I32# y#) = x# `neInt32#` y#++instance Ord Int32 where+    (I32# x#) <  (I32# y#) = x# `ltInt32#` y#+    (I32# x#) <= (I32# y#) = x# `leInt32#` y#+    (I32# x#) >  (I32# y#) = x# `gtInt32#` y#+    (I32# x#) >= (I32# y#) = x# `geInt32#` y#++instance Show Int32 where+    showsPrec p x = showsPrec p (toInteger x)++instance Num Int32 where+    (I32# x#) + (I32# y#)  = I32# (x# `plusInt32#`  y#)+    (I32# x#) - (I32# y#)  = I32# (x# `minusInt32#` y#)+    (I32# x#) * (I32# y#)  = I32# (x# `timesInt32#` y#)+    negate (I32# x#)       = I32# (negateInt32# x#)+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger (S# i#)    = I32# (intToInt32# i#)+    fromInteger (J# s# d#) = I32# (integerToInt32# s# d#)++instance Enum Int32 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int32"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int32"+    toEnum (I# i#)      = I32# (intToInt32# i#)+    fromEnum x@(I32# x#)+        | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)+                        = I# (int32ToInt# x#)+        | otherwise     = fromEnumError "Int32" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Int32 where+    quot    x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (x# `quotInt32#` y#)+    rem     x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = I32# (x# `remInt32#` y#)+    div     x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = I32# (x# `divInt32#` y#)+    mod     x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = I32# (x# `modInt32#` y#)+    quotRem x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = (I32# (x# `quotInt32#` y#),+                                     I32# (x# `remInt32#` y#))+    divMod  x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = (I32# (x# `divInt32#` y#),+                                     I32# (x# `modInt32#` y#))+    toInteger x@(I32# x#)+	| x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)+                                  = smallInteger (int32ToInt# x#)+        | otherwise               = case int32ToInteger# x# of (# s, d #) -> J# s d++divInt32#, modInt32# :: Int32# -> Int32# -> Int32#+x# `divInt32#` y#+    | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#)+        = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y#+    | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)+        = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y#+    | otherwise                = x# `quotInt32#` y#+x# `modInt32#` y#+    | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) ||+      (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)+        = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0#+    | otherwise = r#+    where+    r# = x# `remInt32#` y#++instance Read Int32 where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]++instance Bits Int32 where+    {-# INLINE shift #-}++    (I32# x#) .&.   (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#))+    (I32# x#) .|.   (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `or32#`  int32ToWord32# y#))+    (I32# x#) `xor` (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#))+    complement (I32# x#)       = I32# (word32ToInt32# (not32# (int32ToWord32# x#)))+    (I32# x#) `shift` (I# i#)+        | i# >=# 0#            = I32# (x# `iShiftL32#` i#)+        | otherwise            = I32# (x# `iShiftRA32#` negateInt# i#)+    (I32# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I32# x#+        | otherwise+        = I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#`+                                (x'# `shiftRL32#` (32# -# i'#))))+        where+        x'# = int32ToWord32# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                 = 32+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int->Int32"    fromIntegral = \(I#   x#) -> I32# (intToInt32# x#)+"fromIntegral/Word->Int32"   fromIntegral = \(W#   x#) -> I32# (word32ToInt32# (wordToWord32# x#))+"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#)+"fromIntegral/Int32->Int"    fromIntegral = \(I32# x#) -> I#   (int32ToInt# x#)+"fromIntegral/Int32->Word"   fromIntegral = \(I32# x#) -> W#   (int2Word# (int32ToInt# x#))+"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#)+"fromIntegral/Int32->Int32"  fromIntegral = id :: Int32 -> Int32+  #-}++#else ++-- Int32 is represented in the same way as Int.+#if WORD_SIZE_IN_BITS > 32+-- Operations may assume and must ensure that it holds only values+-- from its logical range.+#endif++data Int32 = I32# Int# deriving (Eq, Ord)+-- ^ 32-bit signed integer type++instance Show Int32 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int32 where+    (I32# x#) + (I32# y#)  = I32# (narrow32Int# (x# +# y#))+    (I32# x#) - (I32# y#)  = I32# (narrow32Int# (x# -# y#))+    (I32# x#) * (I32# y#)  = I32# (narrow32Int# (x# *# y#))+    negate (I32# x#)       = I32# (narrow32Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I32# (narrow32Int# (toInt# i))++instance Enum Int32 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int32"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int32"+#if WORD_SIZE_IN_BITS == 32+    toEnum (I# i#)      = I32# i#+#else+    toEnum i@(I# i#)+        | i >= fromIntegral (minBound::Int32) && i <= fromIntegral (maxBound::Int32)+                        = I32# i#+        | otherwise     = toEnumError "Int32" i (minBound::Int32, maxBound::Int32)+#endif+    fromEnum (I32# x#)  = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int32 where+    quot    x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `quotInt#` y#))+    rem     x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `remInt#` y#))+    div     x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `divInt#` y#))+    mod     x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `modInt#` y#))+    quotRem x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I32# (narrow32Int# (x# `quotInt#` y#)),+                                     I32# (narrow32Int# (x# `remInt#` y#)))+    divMod  x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I32# (narrow32Int# (x# `divInt#` y#)),+                                     I32# (narrow32Int# (x# `modInt#` y#)))+    toInteger (I32# x#)              = smallInteger x#++instance Read Int32 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int32 where+    {-# INLINE shift #-}++    (I32# x#) .&.   (I32# y#)  = I32# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I32# x#) .|.   (I32# y#)  = I32# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I32# x#) `xor` (I32# y#)  = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I32# x#)       = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I32# x#) `shift` (I# i#)+        | i# >=# 0#            = I32# (narrow32Int# (x# `iShiftL#` i#))+        | otherwise            = I32# (x# `iShiftRA#` negateInt# i#)+    (I32# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I32# x#+        | otherwise+        = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                         (x'# `uncheckedShiftRL#` (32# -# i'#)))))+        where+        x'# = narrow32Word# (int2Word# x#)+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                 = 32+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Int32"  fromIntegral = \(W8# x#) -> I32# (word2Int# x#)+"fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#)+"fromIntegral/Int8->Int32"   fromIntegral = \(I8# x#) -> I32# x#+"fromIntegral/Int16->Int32"  fromIntegral = \(I16# x#) -> I32# x#+"fromIntegral/Int32->Int32"  fromIntegral = id :: Int32 -> Int32+"fromIntegral/a->Int32"      fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#)+"fromIntegral/Int32->a"      fromIntegral = \(I32# x#) -> fromIntegral (I# x#)+  #-}++#endif ++instance Real Int32 where+    toRational x = toInteger x % 1++instance Bounded Int32 where+    minBound = -0x80000000+    maxBound =  0x7FFFFFFF++instance Ix Int32 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n++------------------------------------------------------------------------+-- type Int64+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 64++data Int64 = I64# Int64#+-- ^ 64-bit signed integer type++instance Eq Int64 where+    (I64# x#) == (I64# y#) = x# `eqInt64#` y#+    (I64# x#) /= (I64# y#) = x# `neInt64#` y#++instance Ord Int64 where+    (I64# x#) <  (I64# y#) = x# `ltInt64#` y#+    (I64# x#) <= (I64# y#) = x# `leInt64#` y#+    (I64# x#) >  (I64# y#) = x# `gtInt64#` y#+    (I64# x#) >= (I64# y#) = x# `geInt64#` y#++instance Show Int64 where+    showsPrec p x = showsPrec p (toInteger x)++instance Num Int64 where+    (I64# x#) + (I64# y#)  = I64# (x# `plusInt64#`  y#)+    (I64# x#) - (I64# y#)  = I64# (x# `minusInt64#` y#)+    (I64# x#) * (I64# y#)  = I64# (x# `timesInt64#` y#)+    negate (I64# x#)       = I64# (negateInt64# x#)+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I64# (integerToInt64 i)++instance Enum Int64 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int64"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int64"+    toEnum (I# i#)      = I64# (intToInt64# i#)+    fromEnum x@(I64# x#)+        | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)+                        = I# (int64ToInt# x#)+        | otherwise     = fromEnumError "Int64" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Int64 where+    quot    x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `quotInt64#` y#)+    rem     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `remInt64#` y#)+    div     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `divInt64#` y#)+    mod     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `modInt64#` y#)+    quotRem x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `quotInt64#` y#),+                                        I64# (x# `remInt64#` y#))+    divMod  x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `divInt64#` y#),+                                        I64# (x# `modInt64#` y#))+    toInteger (I64# x)               = int64ToInteger x+++divInt64#, modInt64# :: Int64# -> Int64# -> Int64#+x# `divInt64#` y#+    | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#)+        = ((x# `minusInt64#` y#) `minusInt64#` intToInt64# 1#) `quotInt64#` y#+    | (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#)+        = ((x# `minusInt64#` y#) `plusInt64#` intToInt64# 1#) `quotInt64#` y#+    | otherwise                = x# `quotInt64#` y#+x# `modInt64#` y#+    | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) ||+      (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#)+        = if r# `neInt64#` intToInt64# 0# then r# `plusInt64#` y# else intToInt64# 0#+    | otherwise = r#+    where+    r# = x# `remInt64#` y#++instance Read Int64 where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]++instance Bits Int64 where+    {-# INLINE shift #-}++    (I64# x#) .&.   (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#))+    (I64# x#) .|.   (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `or64#`  int64ToWord64# y#))+    (I64# x#) `xor` (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#))+    complement (I64# x#)       = I64# (word64ToInt64# (not64# (int64ToWord64# x#)))+    (I64# x#) `shift` (I# i#)+        | i# >=# 0#            = I64# (x# `iShiftL64#` i#)+        | otherwise            = I64# (x# `iShiftRA64#` negateInt# i#)+    (I64# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I64# x#+        | otherwise+        = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#`+                                (x'# `uncheckedShiftRL64#` (64# -# i'#))))+        where+        x'# = int64ToWord64# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                 = 64+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)+++-- give the 64-bit shift operations the same treatment as the 32-bit+-- ones (see GHC.Base), namely we wrap them in tests to catch the+-- cases when we're shifting more than 64 bits to avoid unspecified+-- behaviour in the C shift operations.++iShiftL64#, iShiftRA64# :: Int64# -> Int# -> Int64#++a `iShiftL64#` b  | b >=# 64# = intToInt64# 0#+		  | otherwise = a `uncheckedIShiftL64#` b++a `iShiftRA64#` b | b >=# 64# = if a `ltInt64#` (intToInt64# 0#) +					then intToInt64# (-1#) +					else intToInt64# 0#+		  | otherwise = a `uncheckedIShiftRA64#` b++{-# RULES+"fromIntegral/Int->Int64"    fromIntegral = \(I#   x#) -> I64# (intToInt64# x#)+"fromIntegral/Word->Int64"   fromIntegral = \(W#   x#) -> I64# (word64ToInt64# (wordToWord64# x#))+"fromIntegral/Word64->Int64" fromIntegral = \(W64# x#) -> I64# (word64ToInt64# x#)+"fromIntegral/Int64->Int"    fromIntegral = \(I64# x#) -> I#   (int64ToInt# x#)+"fromIntegral/Int64->Word"   fromIntegral = \(I64# x#) -> W#   (int2Word# (int64ToInt# x#))+"fromIntegral/Int64->Word64" fromIntegral = \(I64# x#) -> W64# (int64ToWord64# x#)+"fromIntegral/Int64->Int64"  fromIntegral = id :: Int64 -> Int64+  #-}++#else ++-- Int64 is represented in the same way as Int.+-- Operations may assume and must ensure that it holds only values+-- from its logical range.++data Int64 = I64# Int# deriving (Eq, Ord)+-- ^ 64-bit signed integer type++instance Show Int64 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int64 where+    (I64# x#) + (I64# y#)  = I64# (x# +# y#)+    (I64# x#) - (I64# y#)  = I64# (x# -# y#)+    (I64# x#) * (I64# y#)  = I64# (x# *# y#)+    negate (I64# x#)       = I64# (negateInt# x#)+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I64# (toInt# i)++instance Enum Int64 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int64"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int64"+    toEnum (I# i#)      = I64# i#+    fromEnum (I64# x#)  = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int64 where+    quot    x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `quotInt#` y#)+    rem     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `remInt#` y#)+    div     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `divInt#` y#)+    mod     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `modInt#` y#)+    quotRem x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#))+    divMod  x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#))+    toInteger (I64# x#)              = smallInteger x#++instance Read Int64 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int64 where+    {-# INLINE shift #-}++    (I64# x#) .&.   (I64# y#)  = I64# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I64# x#) .|.   (I64# y#)  = I64# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I64# x#) `xor` (I64# y#)  = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I64# x#)       = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I64# x#) `shift` (I# i#)+        | i# >=# 0#            = I64# (x# `iShiftL#` i#)+        | otherwise            = I64# (x# `iShiftRA#` negateInt# i#)+    (I64# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I64# x#+        | otherwise+        = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                           (x'# `uncheckedShiftRL#` (64# -# i'#))))+        where+        x'# = int2Word# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                 = 64+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x#+"fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#)+  #-}++uncheckedIShiftL64# :: Int# -> Int# -> Int#+uncheckedIShiftL64#  = uncheckedIShiftL#++uncheckedIShiftRA64# :: Int# -> Int# -> Int#+uncheckedIShiftRA64# = uncheckedIShiftRA#+#endif++instance Real Int64 where+    toRational x = toInteger x % 1++instance Bounded Int64 where+    minBound = -0x8000000000000000+    maxBound =  0x7FFFFFFFFFFFFFFF++instance Ix Int64 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n+
+ lib/base/src/GHC/List.lhs view
@@ -0,0 +1,733 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.List+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The List data type and its operations+--+-----------------------------------------------------------------------------++-- #hide+module GHC.List (+   -- [] (..),          -- Not Haskell 98; built in syntax++   map, (++), filter, concat,+   head, last, tail, init, null, length, (!!),+   foldl, scanl, scanl1, foldr, foldr1, scanr, scanr1,+   iterate, repeat, replicate, cycle,+   take, drop, splitAt, takeWhile, dropWhile, span, break,+   reverse, and, or,+   any, all, elem, notElem, lookup,+   concatMap,+   zip, zip3, zipWith, zipWith3, unzip, unzip3,+   errorEmptyList,++#ifndef USE_REPORT_PRELUDE+   -- non-standard, but hidden when creating the Prelude+   -- export list.+   takeUInt_append+#endif++ ) where++import Data.Maybe+import GHC.Base++infixl 9  !!+infix  4 `elem`, `notElem`+\end{code}++%*********************************************************+%*                                                      *+\subsection{List-manipulation functions}+%*                                                      *+%*********************************************************++\begin{code}+-- | Extract the first element of a list, which must be non-empty.+head                    :: [a] -> a+head (x:_)              =  x+head []                 =  badHead++badHead :: a+badHead = errorEmptyList "head"++-- This rule is useful in cases like +--      head [y | (x,y) <- ps, x==t]+{-# RULES+"head/build"    forall (g::forall b.(a->b->b)->b->b) .+                head (build g) = g (\x _ -> x) badHead+"head/augment"  forall xs (g::forall b. (a->b->b) -> b -> b) . +                head (augment g xs) = g (\x _ -> x) (head xs)+ #-}++-- | Extract the elements after the head of a list, which must be non-empty.+tail                    :: [a] -> [a]+tail (_:xs)             =  xs+tail []                 =  errorEmptyList "tail"++-- | Extract the last element of a list, which must be finite and non-empty.+last                    :: [a] -> a+#ifdef USE_REPORT_PRELUDE+last [x]                =  x+last (_:xs)             =  last xs+last []                 =  errorEmptyList "last"+#else+-- eliminate repeated cases+last []                 =  errorEmptyList "last"+last (x:xs)             =  last' x xs+  where last' y []     = y+        last' _ (y:ys) = last' y ys+#endif++-- | Return all the elements of a list except the last one.+-- The list must be finite and non-empty.+init                    :: [a] -> [a]+#ifdef USE_REPORT_PRELUDE+init [x]                =  []+init (x:xs)             =  x : init xs+init []                 =  errorEmptyList "init"+#else+-- eliminate repeated cases+init []                 =  errorEmptyList "init"+init (x:xs)             =  init' x xs+  where init' _ []     = []+        init' y (z:zs) = y : init' z zs+#endif++-- | Test whether a list is empty.+null                    :: [a] -> Bool+null []                 =  True+null (_:_)              =  False++-- | 'length' returns the length of a finite list as an 'Int'.+-- It is an instance of the more general 'Data.List.genericLength',+-- the result type of which may be any kind of number.+length                  :: [a] -> Int+length l                =  len l 0#+  where+    len :: [a] -> Int# -> Int+    len []     a# = I# a#+    len (_:xs) a# = len xs (a# +# 1#)++-- | 'filter', applied to a predicate and a list, returns the list of+-- those elements that satisfy the predicate; i.e.,+--+-- > filter p xs = [ x | x <- xs, p x]++filter :: (a -> Bool) -> [a] -> [a]+filter _pred []    = []+filter pred (x:xs)+  | pred x         = x : filter pred xs+  | otherwise      = filter pred xs++{-# NOINLINE [0] filterFB #-}+filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+filterFB c p x r | p x       = x `c` r+                 | otherwise = r++{-# RULES+"filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+"filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+"filterFB"        forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)+ #-}++-- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.+--     filterFB (filterFB c p) q a b+--   = if q a then filterFB c p a b else b+--   = if q a then (if p a then c a b else b) else b+--   = if q a && p a then c a b else b+--   = filterFB c (\x -> q x && p x) a b+-- I originally wrote (\x -> p x && q x), which is wrong, and actually+-- gave rise to a live bug report.  SLPJ.+++-- | '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+--+-- The list must be finite.++-- We write foldl as a non-recursive thing, so that it+-- can be inlined, and then (often) strictness-analysed,+-- and hence the classic space leak on foldl (+) 0 xs++foldl        :: (a -> b -> a) -> a -> [b] -> a+foldl f z0 xs0 = lgo z0 xs0+             where+                lgo z []     =  z+                lgo z (x:xs) = lgo (f z x) xs++-- | '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.++scanl                   :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q ls            =  q : (case ls of+                                []   -> []+                                x:xs -> scanl f (f q x) xs)++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:+--+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]++scanl1                  :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)         =  scanl f x xs+scanl1 _ []             =  []++-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the+-- above functions.++-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,+-- and thus must be applied to non-empty lists.++foldr1                  :: (a -> a -> a) -> [a] -> a+foldr1 _ [x]            =  x+foldr1 f (x:xs)         =  f x (foldr1 f xs)+foldr1 _ []             =  errorEmptyList "foldr1"++-- | 'scanr' is the right-to-left dual of 'scanl'.+-- Note that+--+-- > head (scanr f z xs) == foldr f z xs.++scanr                   :: (a -> b -> b) -> b -> [a] -> [b]+scanr _ q0 []           =  [q0]+scanr f q0 (x:xs)       =  f x q : qs+                           where qs@(q:_) = scanr f q0 xs ++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.++scanr1                  :: (a -> a -> a) -> [a] -> [a]+scanr1 _ []             =  []+scanr1 _ [x]            =  [x]+scanr1 f (x:xs)         =  f x q : qs+                           where qs@(q:_) = scanr1 f xs ++-- | '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)++iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b+iterateFB c f x = x `c` iterateFB c f (f x)+++{-# RULES+"iterate"    [~1] forall f x.   iterate f x = build (\c _n -> iterateFB c f x)+"iterateFB"  [1]                iterateFB (:) = iterate+ #-}+++-- | 'repeat' @x@ is an infinite list, with @x@ the value of every element.+repeat :: a -> [a]+{-# INLINE [0] repeat #-}+-- The pragma just gives the rules more chance to fire+repeat x = xs where xs = x : xs++{-# INLINE [0] repeatFB #-}     -- ditto+repeatFB :: (a -> b -> b) -> a -> b+repeatFB c x = xs where xs = x `c` xs+++{-# RULES+"repeat"    [~1] forall x. repeat x = build (\c _n -> repeatFB c x)+"repeatFB"  [1]  repeatFB (:)       = repeat+ #-}++-- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of+-- every element.+-- It is an instance of the more general 'Data.List.genericReplicate',+-- in which @n@ may be of any integral type.+{-# INLINE replicate #-}+replicate               :: Int -> a -> [a]+replicate n x           =  take n (repeat x)++-- | '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'++-- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the+-- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@:+--+-- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2]+-- > takeWhile (< 9) [1,2,3] == [1,2,3]+-- > takeWhile (< 0) [1,2,3] == []+--++takeWhile               :: (a -> Bool) -> [a] -> [a]+takeWhile _ []          =  []+takeWhile p (x:xs) +            | p x       =  x : takeWhile p xs+            | otherwise =  []++-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@:+--+-- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3]+-- > dropWhile (< 9) [1,2,3] == []+-- > dropWhile (< 0) [1,2,3] == [1,2,3]+--++dropWhile               :: (a -> Bool) -> [a] -> [a]+dropWhile _ []          =  []+dropWhile p xs@(x:xs')+            | p x       =  dropWhile p xs'+            | otherwise =  xs++-- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@+-- of length @n@, or @xs@ itself if @n > 'length' xs@:+--+-- > take 5 "Hello World!" == "Hello"+-- > take 3 [1,2,3,4,5] == [1,2,3]+-- > take 3 [1,2] == [1,2]+-- > take 3 [] == []+-- > take (-1) [1,2] == []+-- > take 0 [1,2] == []+--+-- It is an instance of the more general 'Data.List.genericTake',+-- in which @n@ may be of any integral type.+take                   :: Int -> [a] -> [a]++-- | 'drop' @n xs@ returns the suffix of @xs@+-- after the first @n@ elements, or @[]@ if @n > 'length' xs@:+--+-- > drop 6 "Hello World!" == "World!"+-- > drop 3 [1,2,3,4,5] == [4,5]+-- > drop 3 [1,2] == []+-- > drop 3 [] == []+-- > drop (-1) [1,2] == [1,2]+-- > drop 0 [1,2] == [1,2]+--+-- It is an instance of the more general 'Data.List.genericDrop',+-- in which @n@ may be of any integral type.+drop                   :: Int -> [a] -> [a]++-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of+-- length @n@ and second element is the remainder of the list:+--+-- > splitAt 6 "Hello World!" == ("Hello ","World!")+-- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5])+-- > splitAt 1 [1,2,3] == ([1],[2,3])+-- > splitAt 3 [1,2,3] == ([1,2,3],[])+-- > splitAt 4 [1,2,3] == ([1,2,3],[])+-- > splitAt 0 [1,2,3] == ([],[1,2,3])+-- > splitAt (-1) [1,2,3] == ([],[1,2,3])+--+-- It is equivalent to @('take' n xs, 'drop' n xs)@.+-- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt',+-- in which @n@ may be of any integral type.+splitAt                :: Int -> [a] -> ([a],[a])++#ifdef USE_REPORT_PRELUDE+take n _      | n <= 0 =  []+take _ []              =  []+take n (x:xs)          =  x : take (n-1) xs++drop n xs     | n <= 0 =  xs+drop _ []              =  []+drop n (_:xs)          =  drop (n-1) xs++splitAt n xs           =  (take n xs, drop n xs)++#else /* hack away */+{-# RULES+"take"     [~1] forall n xs . take n xs = takeFoldr n xs +"takeList"  [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs+ #-}++{-# INLINE takeFoldr #-}+takeFoldr :: Int -> [a] -> [a]+takeFoldr (I# n#) xs+  = build (\c nil -> if n# <=# 0# then nil else+                     foldr (takeFB c nil) (takeConst nil) xs n#)++{-# 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 -> b) -> b -> a -> (Int# -> b) -> Int# -> b+takeFB c n x xs m | m <=# 1#  = x `c` n+                  | otherwise = x `c` xs (m -# 1#)++{-# INLINE [0] take #-}+take (I# n#) xs = takeUInt n# xs++-- The general code for take, below, checks n <= maxInt+-- No need to check for maxInt overflow when specialised+-- at type Int or Int# since the Int must be <= maxInt++takeUInt :: Int# -> [b] -> [b]+takeUInt n xs+  | n >=# 0#  =  take_unsafe_UInt n xs+  | otherwise =  []++take_unsafe_UInt :: Int# -> [b] -> [b]+take_unsafe_UInt 0#  _  = []+take_unsafe_UInt m   ls =+  case ls of+    []     -> []+    (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs++takeUInt_append :: Int# -> [b] -> [b] -> [b]+takeUInt_append n xs rs+  | n >=# 0#  =  take_unsafe_UInt_append n xs rs+  | otherwise =  []++take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b]+take_unsafe_UInt_append 0#  _ rs  = rs+take_unsafe_UInt_append m  ls rs  =+  case ls of+    []     -> rs+    (x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs++drop (I# n#) ls+  | n# <# 0#    = ls+  | otherwise   = drop# n# ls+    where+        drop# :: Int# -> [a] -> [a]+        drop# 0# xs      = xs+        drop# _  xs@[]   = xs+        drop# m# (_:xs)  = drop# (m# -# 1#) xs++splitAt (I# n#) ls+  | n# <# 0#    = ([], ls)+  | otherwise   = splitAt# n# ls+    where+        splitAt# :: Int# -> [a] -> ([a], [a])+        splitAt# 0# xs     = ([], xs)+        splitAt# _  xs@[]  = (xs, xs)+        splitAt# m# (x:xs) = (x:xs', xs'')+          where+            (xs', xs'') = splitAt# (m# -# 1#) xs++#endif /* USE_REPORT_PRELUDE */++-- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where+-- first element is longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@ and second element is the remainder of the list:+-- +-- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4])+-- > span (< 9) [1,2,3] == ([1,2,3],[])+-- > span (< 0) [1,2,3] == ([],[1,2,3])+-- +-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@++span                    :: (a -> Bool) -> [a] -> ([a],[a])+span _ xs@[]            =  (xs, xs)+span p xs@(x:xs')+         | p x          =  let (ys,zs) = span p xs' in (x:ys,zs)+         | otherwise    =  ([],xs)++-- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where+-- first element is longest prefix (possibly empty) of @xs@ of elements that+-- /do not satisfy/ @p@ and second element is the remainder of the list:+-- +-- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4])+-- > break (< 9) [1,2,3] == ([],[1,2,3])+-- > break (> 9) [1,2,3] == ([1,2,3],[])+--+-- 'break' @p@ is equivalent to @'span' ('not' . p)@.++break                   :: (a -> Bool) -> [a] -> ([a],[a])+#ifdef USE_REPORT_PRELUDE+break p                 =  span (not . p)+#else+-- HBC version (stolen)+break _ xs@[]           =  (xs, xs)+break p xs@(x:xs')+           | p x        =  ([],xs)+           | otherwise  =  let (ys,zs) = break p xs' in (x:ys,zs)+#endif++-- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.+-- @xs@ must be finite.+reverse                 :: [a] -> [a]+#ifdef USE_REPORT_PRELUDE+reverse                 =  foldl (flip (:)) []+#else+reverse l =  rev l []+  where+    rev []     a = a+    rev (x:xs) a = rev xs (x:a)+#endif++-- | 'and' returns the conjunction of a Boolean list.  For the result to be+-- 'True', the list must be finite; 'False', however, results from a 'False'+-- value at a finite index of a finite or infinite list.+and                     :: [Bool] -> Bool++-- | 'or' returns the disjunction of a Boolean list.  For the result to be+-- 'False', the list must be finite; 'True', however, results from a 'True'+-- value at a finite index of a finite or infinite list.+or                      :: [Bool] -> Bool+#ifdef USE_REPORT_PRELUDE+and                     =  foldr (&&) True+or                      =  foldr (||) False+#else+and []          =  True+and (x:xs)      =  x && and xs+or []           =  False+or (x:xs)       =  x || or xs++{-# RULES+"and/build"     forall (g::forall b.(Bool->b->b)->b->b) . +                and (build g) = g (&&) True+"or/build"      forall (g::forall b.(Bool->b->b)->b->b) . +                or (build g) = g (||) False+ #-}+#endif++-- | Applied to a predicate and a list, 'any' determines if any element+-- of the list satisfies the predicate.+any                     :: (a -> Bool) -> [a] -> Bool++-- | Applied to a predicate and a list, 'all' determines if all elements+-- of the list satisfy the predicate.+all                     :: (a -> Bool) -> [a] -> Bool+#ifdef USE_REPORT_PRELUDE+any p                   =  or . map p+all p                   =  and . map p+#else+any _ []        = False+any p (x:xs)    = p x || any p xs++all _ []        =  True+all p (x:xs)    =  p x && all p xs+{-# RULES+"any/build"     forall p (g::forall b.(a->b->b)->b->b) . +                any p (build g) = g ((||) . p) False+"all/build"     forall p (g::forall b.(a->b->b)->b->b) . +                all p (build g) = g ((&&) . p) True+ #-}+#endif++-- | 'elem' is the list membership predicate, usually written in infix form,+-- e.g., @x \`elem\` xs@.+elem                    :: (Eq a) => a -> [a] -> Bool++-- | 'notElem' is the negation of 'elem'.+notElem                 :: (Eq a) => a -> [a] -> Bool+#ifdef USE_REPORT_PRELUDE+elem x                  =  any (== x)+notElem x               =  all (/= x)+#else+elem _ []       = False+elem x (y:ys)   = x==y || elem x ys++notElem _ []    =  True+notElem x (y:ys)=  x /= y && notElem x ys+#endif++-- | 'lookup' @key assocs@ looks up a key in an association list.+lookup                  :: (Eq a) => a -> [(a,b)] -> Maybe b+lookup _key []          =  Nothing+lookup  key ((x,y):xys)+    | key == x          =  Just y+    | otherwise         =  lookup key xys++-- | Map a function over a list and concatenate the results.+concatMap               :: (a -> [b]) -> [a] -> [b]+concatMap f             =  foldr ((++) . f) []++-- | Concatenate a list of lists.+concat :: [[a]] -> [a]+concat = foldr (++) []++{-# RULES+  "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)+-- We don't bother to turn non-fusible applications of concat back into concat+ #-}++\end{code}+++\begin{code}+-- | List index (subscript) operator, starting from 0.+-- It is an instance of the more general 'Data.List.genericIndex',+-- which takes an index of any integral type.+(!!)                    :: [a] -> Int -> a+#ifdef USE_REPORT_PRELUDE+xs     !! n | n < 0 =  error "Prelude.!!: negative index"+[]     !! _         =  error "Prelude.!!: index too large"+(x:_)  !! 0         =  x+(_:xs) !! n         =  xs !! (n-1)+#else+-- HBC version (stolen), then unboxified+-- The semantics is not quite the same for error conditions+-- in the more efficient version.+--+xs !! (I# n0) | n0 <# 0#   =  error "Prelude.(!!): negative index\n"+               | otherwise =  sub xs n0+                         where+                            sub :: [a] -> Int# -> a+                            sub []     _ = error "Prelude.(!!): index too large\n"+                            sub (y:ys) n = if n ==# 0#+                                           then y+                                           else sub ys (n -# 1#)+#endif+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The zip family}+%*                                                      *+%*********************************************************++\begin{code}+foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c+foldr2 _k z []    _ys    = z+foldr2 _k z _xs   []     = z+foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys)++foldr2_left :: (a -> b -> c -> d) -> d -> a -> ([b] -> c) -> [b] -> d+foldr2_left _k  z _x _r []     = z+foldr2_left  k _z  x  r (y:ys) = k x y (r ys)++foldr2_right :: (a -> b -> c -> d) -> d -> b -> ([a] -> c) -> [a] -> d+foldr2_right _k z  _y _r []     = z+foldr2_right  k _z  y  r (x:xs) = k x y (r xs)++-- foldr2 k z xs ys = foldr (foldr2_left k z)  (\_ -> z) xs ys+-- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs+{-# RULES+"foldr2/left"   forall k z ys (g::forall b.(a->b->b)->b->b) . +                  foldr2 k z (build g) ys = g (foldr2_left  k z) (\_ -> z) ys++"foldr2/right"  forall k z xs (g::forall b.(a->b->b)->b->b) . +                  foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs+ #-}+\end{code}++The foldr2/right rule isn't exactly right, because it changes+the strictness of foldr2 (and thereby zip)++E.g. main = print (null (zip nonobviousNil (build undefined)))+          where   nonobviousNil = f 3+                  f n = if n == 0 then [] else f (n-1)++I'm going to leave it though.+++Zips for larger tuples are in the List module.++\begin{code}+----------------------------------------------+-- | '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.+zip :: [a] -> [b] -> [(a,b)]+zip (a:as) (b:bs) = (a,b) : zip as bs+zip _      _      = []++{-# INLINE [0] zipFB #-}+zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d+zipFB c x y r = (x,y) `c` r++{-# RULES+"zip"      [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)+"zipList"  [1]  foldr2 (zipFB (:)) []   = zip+ #-}+\end{code}++\begin{code}+----------------------------------------------+-- | 'zip3' takes three lists and returns a list of triples, analogous to+-- 'zip'.+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]+-- Specification+-- zip3 =  zipWith3 (,,)+zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs+zip3 _      _      _      = []+\end{code}+++-- The zipWith family generalises the zip family by zipping with the+-- function given as the first argument, instead of a tupling function.++\begin{code}+----------------------------------------------+-- | 'zipWith' generalises 'zip' 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 f (a:as) (b:bs) = f a b : zipWith f as bs+zipWith _ _      _      = []++{-# INLINE [0] zipWithFB #-}+zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c+zipWithFB c f x y r = (x `f` y) `c` r++{-# RULES+"zipWith"       [~1] forall f xs ys.    zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)+"zipWithList"   [1]  forall f.  foldr2 (zipWithFB (:) f) [] = zipWith f+  #-}+\end{code}++\begin{code}+-- | The 'zipWith3' function takes a function which combines three+-- elements, as well as three lists and returns a list of their point-wise+-- combination, analogous to 'zipWith'.+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 list of first components+-- and a list of second components.+unzip    :: [(a,b)] -> ([a],[b])+{-# INLINE unzip #-}+unzip    =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])++-- | The 'unzip3' function takes a list of triples and returns three+-- lists, analogous to 'unzip'.+unzip3   :: [(a,b,c)] -> ([a],[b],[c])+{-# INLINE unzip3 #-}+unzip3   =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+                  ([],[],[])+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Error code}+%*                                                      *+%*********************************************************++Common up near identical calls to `error' to reduce the number+constant strings created when compiled:++\begin{code}+errorEmptyList :: String -> a+errorEmptyList fun =+  error (prel_list_str ++ fun ++ ": empty list")++prel_list_str :: String+prel_list_str = "Prelude."+\end{code}
+ lib/base/src/GHC/Num.lhs view
@@ -0,0 +1,327 @@+\begin{code}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Num+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Num' class and the 'Integer' type.+--+-----------------------------------------------------------------------------++#if WORD_SIZE == 4+#define DIGITS       9+#define BASE         1000000000+#elif WORD_SIZE == 8+#define DIGITS       18+#define BASE         1000000000000000000+#else+#error Please define DIGITS and BASE+-- DIGITS should be the largest integer such that+--     10^DIGITS < 2^(SIZEOF_HSWORD * 8 - 1)+-- BASE should be 10^DIGITS. Note that ^ is not available yet.+#endif++-- #hide+module GHC.Num (module GHC.Num, module GHC.Integer) where++import GHC.Base+import GHC.Enum+import GHC.Show+import GHC.Integer++infixl 7  *+infixl 6  +, -++default ()              -- Double isn't available yet, +                        -- and we shouldn't be using defaults anyway+\end{code}++%*********************************************************+%*                                                      *+\subsection{Standard numeric class}+%*                                                      *+%*********************************************************++\begin{code}+-- | Basic numeric class.+--+-- Minimal complete definition: all except 'negate' or @(-)@+class  (Eq a, Show a) => Num a  where+    (+), (-), (*)       :: a -> a -> a+    -- | Unary negation.+    negate              :: a -> a+    -- | Absolute value.+    abs                 :: a -> a+    -- | Sign of a number.+    -- The functions 'abs' and 'signum' should satisfy the law: +    --+    -- > abs x * signum x == x+    --+    -- For real numbers, the 'signum' is either @-1@ (negative), @0@ (zero)+    -- or @1@ (positive).+    signum              :: a -> a+    -- | Conversion from an 'Integer'.+    -- An integer literal represents the application of the function+    -- 'fromInteger' to the appropriate value of type 'Integer',+    -- so such literals have type @('Num' a) => a@.+    fromInteger         :: Integer -> a++    x - y               = x + negate y+    negate x            = 0 - x++-- | the same as @'flip' ('-')@.+--+-- Because @-@ is treated specially in the Haskell grammar,+-- @(-@ /e/@)@ is not a section, but an application of prefix negation.+-- However, @('subtract'@ /exp/@)@ is equivalent to the disallowed section.+{-# INLINE subtract #-}+subtract :: (Num a) => a -> a -> a+subtract x y = y - x+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Int@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Num Int  where+    (+)    = plusInt+    (-)    = minusInt+    negate = negateInt+    (*)    = timesInt+    abs n  = if n `geInt` 0 then n else negateInt n++    signum n | n `ltInt` 0 = negateInt 1+             | n `eqInt` 0 = 0+             | otherwise   = 1++    fromInteger i = I# (toInt# i)++quotRemInt :: Int -> Int -> (Int, Int)+quotRemInt a@(I# _) b@(I# _) = (a `quotInt` b, a `remInt` b)+    -- OK, so I made it a little stricter.  Shoot me.  (WDP 94/10)++divModInt ::  Int -> Int -> (Int, Int)+divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y)+    -- Stricter.  Sorry if you don't like it.  (WDP 94/10)+\end{code}++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Eq@, @Ord@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Eq Integer  where+    (==) = eqInteger+    (/=) = neqInteger++------------------------------------------------------------------------+instance Ord Integer where+    (<=) = leInteger+    (>)  = gtInteger+    (<)  = ltInteger+    (>=) = geInteger+    compare = compareInteger+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Show@}+%*                                                      *+%*********************************************************++\begin{code}+instance Show Integer where+    showsPrec p n r+        | p > 6 && n < 0 = '(' : integerToString n (')' : r)+        -- Minor point: testing p first gives better code+        -- in the not-uncommon case where the p argument+        -- is a constant+        | otherwise = integerToString n r+    showList = showList__ (showsPrec 0)++-- Divide an conquer implementation of string conversion+integerToString :: Integer -> String -> String+integerToString n0 cs0+    | n0 < 0    = '-' : integerToString' (- n0) cs0+    | otherwise = integerToString' n0 cs0+    where+    integerToString' :: Integer -> String -> String+    integerToString' n cs+        | n < BASE  = jhead (fromInteger n) cs+        | otherwise = jprinth (jsplitf (BASE*BASE) n) cs++    -- Split n into digits in base p. We first split n into digits+    -- in base p*p and then split each of these digits into two.+    -- Note that the first 'digit' modulo p*p may have a leading zero+    -- in base p that we need to drop - this is what jsplith takes care of.+    -- jsplitb the handles the remaining digits.+    jsplitf :: Integer -> Integer -> [Integer]+    jsplitf p n+        | p > n     = [n]+        | otherwise = jsplith p (jsplitf (p*p) n)++    jsplith :: Integer -> [Integer] -> [Integer]+    jsplith p (n:ns) =+        case n `quotRemInteger` p of+        (# q, r #) ->+            if q > 0 then fromInteger q : fromInteger r : jsplitb p ns+                     else fromInteger r : jsplitb p ns+    jsplith _ [] = error "jsplith: []"++    jsplitb :: Integer -> [Integer] -> [Integer]+    jsplitb _ []     = []+    jsplitb p (n:ns) = case n `quotRemInteger` p of+                       (# q, r #) ->+                           q : r : jsplitb p ns++    -- Convert a number that has been split into digits in base BASE^2+    -- this includes a last splitting step and then conversion of digits+    -- that all fit into a machine word.+    jprinth :: [Integer] -> String -> String+    jprinth (n:ns) cs =+        case n `quotRemInteger` BASE of+        (# q', r' #) ->+            let q = fromInteger q'+                r = fromInteger r'+            in if q > 0 then jhead q $ jblock r $ jprintb ns cs+                        else jhead r $ jprintb ns cs+    jprinth [] _ = error "jprinth []"++    jprintb :: [Integer] -> String -> String+    jprintb []     cs = cs+    jprintb (n:ns) cs = case n `quotRemInteger` BASE of+                        (# q', r' #) ->+                            let q = fromInteger q'+                                r = fromInteger r'+                            in jblock q $ jblock r $ jprintb ns cs++    -- Convert an integer that fits into a machine word. Again, we have two+    -- functions, one that drops leading zeros (jhead) and one that doesn't+    -- (jblock)+    jhead :: Int -> String -> String+    jhead n cs+        | n < 10    = case unsafeChr (ord '0' + n) of+            c@(C# _) -> c : cs+        | otherwise = case unsafeChr (ord '0' + r) of+            c@(C# _) -> jhead q (c : cs)+        where+        (q, r) = n `quotRemInt` 10++    jblock = jblock' {- ' -} DIGITS++    jblock' :: Int -> Int -> String -> String+    jblock' d n cs+        | d == 1    = case unsafeChr (ord '0' + n) of+             c@(C# _) -> c : cs+        | otherwise = case unsafeChr (ord '0' + r) of+             c@(C# _) -> jblock' (d - 1) q (c : cs)+        where+        (q, r) = n `quotRemInt` 10+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Num@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Num Integer  where+    (+) = plusInteger+    (-) = minusInteger+    (*) = timesInteger+    negate         = negateInteger+    fromInteger x  =  x++    abs = absInteger+    signum = signumInteger+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instance for @Enum@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Enum Integer  where+    succ x               = x + 1+    pred x               = x - 1+    toEnum (I# n)        = smallInteger n+    fromEnum n           = I# (toInt# n)++    {-# INLINE enumFrom #-}+    {-# INLINE enumFromThen #-}+    {-# INLINE enumFromTo #-}+    {-# INLINE enumFromThenTo #-}+    enumFrom x             = enumDeltaInteger  x 1+    enumFromThen x y       = enumDeltaInteger  x (y-x)+    enumFromTo x lim       = enumDeltaToInteger x 1     lim+    enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim++{-# RULES+"enumDeltaInteger"      [~1] forall x y.  enumDeltaInteger x y     = build (\c _ -> enumDeltaIntegerFB c x y)+"efdtInteger"           [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)+"enumDeltaInteger"      [1] enumDeltaIntegerFB   (:)    = enumDeltaInteger+"enumDeltaToInteger"    [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger+ #-}++enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b+enumDeltaIntegerFB c x d = x `seq` (x `c` enumDeltaIntegerFB c (x+d) d)++enumDeltaInteger :: Integer -> Integer -> [Integer]+enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d)+-- strict accumulator, so+--     head (drop 1000000 [1 .. ]+-- works++enumDeltaToIntegerFB :: (Integer -> a -> a) -> a+                     -> Integer -> Integer -> Integer -> a+enumDeltaToIntegerFB c n x delta lim+  | delta >= 0 = up_fb c n x delta lim+  | otherwise  = dn_fb c n x delta lim++enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer]+enumDeltaToInteger x delta lim+  | delta >= 0 = up_list x delta lim+  | otherwise  = dn_list x delta lim++up_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a+up_fb c n x0 delta lim = go (x0 :: Integer)+                      where+                        go x | x > lim   = n+                             | otherwise = x `c` go (x+delta)+dn_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a+dn_fb c n x0 delta lim = go (x0 :: Integer)+                      where+                        go x | x < lim   = n+                             | otherwise = x `c` go (x+delta)++up_list :: Integer -> Integer -> Integer -> [Integer]+up_list x0 delta lim = go (x0 :: Integer)+                    where+                        go x | x > lim   = []+                             | otherwise = x : go (x+delta)+dn_list :: Integer -> Integer -> Integer -> [Integer]+dn_list x0 delta lim = go (x0 :: Integer)+                    where+                        go x | x < lim   = []+                             | otherwise = x : go (x+delta)+\end{code}+
+ lib/base/src/GHC/Pack.lhs view
@@ -0,0 +1,104 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Pack+-- Copyright   :  (c) The University of Glasgow 1997-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides a small set of low-level functions for packing+-- and unpacking a chunk of bytes. Used by code emitted by the compiler+-- plus the prelude libraries.+-- +-- The programmer level view of packed strings is provided by a GHC+-- system library PackedString.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Pack+       (+        -- (**) - emitted by compiler.++        packCString#,      -- :: [Char] -> ByteArray#    (**)+        unpackCString,+        unpackCString#,    -- :: Addr# -> [Char]         (**)+        unpackNBytes#,     -- :: Addr# -> Int# -> [Char] (**)+        unpackFoldrCString#,  -- (**)+        unpackAppendCString#,  -- (**)+       ) +        where++import GHC.Base+import GHC.Err ( error )+import GHC.List ( length )+import GHC.ST+import GHC.Num+import GHC.Ptr++data ByteArray ix              = ByteArray        ix ix ByteArray#+data MutableByteArray s ix     = MutableByteArray ix ix (MutableByteArray# s)++unpackCString :: Ptr a -> [Char]+unpackCString a@(Ptr addr)+  | a == nullPtr  = []+  | otherwise      = unpackCString# addr++packCString#         :: [Char]          -> ByteArray#+packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }++packString :: [Char] -> ByteArray Int+packString str = runST (packStringST str)++packStringST :: [Char] -> ST s (ByteArray Int)+packStringST str =+  let len = length str  in+  packNBytesST len str++packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)+packNBytesST (I# length#) str =+  {- +   allocate an array that will hold the string+   (not forgetting the NUL byte at the end)+  -}+ new_ps_array (length# +# 1#) >>= \ ch_array ->+   -- fill in packed string from "str"+ fill_in ch_array 0# str   >>+   -- freeze the puppy:+ freeze_ps_array ch_array length#+ where+  fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()+  fill_in arr_in# idx [] =+   write_ps_array arr_in# idx (chr# 0#) >>+   return ()++  fill_in arr_in# idx (C# c : cs) =+   write_ps_array arr_in# idx c  >>+   fill_in arr_in# (idx +# 1#) cs++-- (Very :-) ``Specialised'' versions of some CharArray things...++new_ps_array    :: Int# -> ST s (MutableByteArray s Int)+write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s () +freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)++new_ps_array size = ST $ \ s ->+    case (newByteArray# size s)   of { (# s2#, barr# #) ->+    (# s2#, MutableByteArray bot bot barr# #) }+  where+    bot = error "new_ps_array"++write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->+    case writeCharArray# barr# n ch s#  of { s2#   ->+    (# s2#, () #) }++-- same as unsafeFreezeByteArray+freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->+    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->+    (# s2#, ByteArray 0 (I# len#) frozen# #) }+\end{code}
+ lib/base/src/GHC/Ptr.lhs view
@@ -0,0 +1,161 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Ptr+-- Copyright   :  (c) The FFI Task Force, 2000-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Ptr' and 'FunPtr' types and operations.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Ptr where++import GHC.Base+import GHC.Show+import GHC.Num+import GHC.List ( length, replicate )+import Numeric          ( showHex )++------------------------------------------------------------------------+-- Data pointers.++data Ptr a = Ptr Addr# deriving (Eq, Ord)+-- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an+-- array of objects, which may be marshalled to or from Haskell values+-- of type @a@.+--+-- The type @a@ will often be an instance of class+-- 'Foreign.Storable.Storable' which provides the marshalling operations.+-- However this is not essential, and you can provide your own operations+-- to access the pointer.  For example you might write small foreign+-- functions to get or set the fields of a C @struct@.++-- |The constant 'nullPtr' contains a distinguished value of 'Ptr'+-- that is not associated with a valid memory location.+nullPtr :: Ptr a+nullPtr = Ptr nullAddr#++-- |The 'castPtr' function casts a pointer from one type to another.+castPtr :: Ptr a -> Ptr b+castPtr (Ptr addr) = Ptr addr++-- |Advances the given address by the given offset in bytes.+plusPtr :: Ptr a -> Int -> Ptr b+plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d)++-- |Given an arbitrary address and an alignment constraint,+-- 'alignPtr' yields the next higher address that fulfills the+-- alignment constraint.  An alignment constraint @x@ is fulfilled by+-- any address divisible by @x@.  This operation is idempotent.+alignPtr :: Ptr a -> Int -> Ptr a+alignPtr addr@(Ptr a) (I# i)+  = case remAddr# a i of {+      0# -> addr;+      n -> Ptr (plusAddr# a (i -# n)) }++-- |Computes the offset required to get from the second to the first+-- argument.  We have +--+-- > p2 == p1 `plusPtr` (p2 `minusPtr` p1)+minusPtr :: Ptr a -> Ptr b -> Int+minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2)++------------------------------------------------------------------------+-- Function pointers for the default calling convention.++data FunPtr a = FunPtr Addr# deriving (Eq, Ord)+-- ^ A value of type @'FunPtr' a@ is a pointer to a function callable+-- from foreign code.  The type @a@ will normally be a /foreign type/,+-- a function type with zero or more arguments where+--+-- * the argument types are /marshallable foreign types/,+--   i.e. 'Char', 'Int', 'Prelude.Double', 'Prelude.Float',+--   'Bool', 'Data.Int.Int8', 'Data.Int.Int16', 'Data.Int.Int32',+--   'Data.Int.Int64', 'Data.Word.Word8', 'Data.Word.Word16',+--   'Data.Word.Word32', 'Data.Word.Word64', @'Ptr' a@, @'FunPtr' a@,+--   @'Foreign.StablePtr.StablePtr' a@ or a renaming of any of these+--   using @newtype@.+-- +-- * the return type is either a marshallable foreign type or has the form+--   @'Prelude.IO' t@ where @t@ is a marshallable foreign type or @()@.+--+-- A value of type @'FunPtr' a@ may be a pointer to a foreign function,+-- either returned by another foreign function or imported with a+-- a static address import like+--+-- > foreign import ccall "stdlib.h &free"+-- >   p_free :: FunPtr (Ptr a -> IO ())+--+-- or a pointer to a Haskell function created using a /wrapper/ stub+-- declared to produce a 'FunPtr' of the correct type.  For example:+--+-- > type Compare = Int -> Int -> Bool+-- > foreign import ccall "wrapper"+-- >   mkCompare :: Compare -> IO (FunPtr Compare)+--+-- Calls to wrapper stubs like @mkCompare@ allocate storage, which+-- should be released with 'Foreign.Ptr.freeHaskellFunPtr' when no+-- longer required.+--+-- To convert 'FunPtr' values to corresponding Haskell functions, one+-- can define a /dynamic/ stub for the specific foreign type, e.g.+--+-- > type IntFunction = CInt -> IO ()+-- > foreign import ccall "dynamic" +-- >   mkFun :: FunPtr IntFunction -> IntFunction++-- |The constant 'nullFunPtr' contains a+-- distinguished value of 'FunPtr' that is not+-- associated with a valid memory location.+nullFunPtr :: FunPtr a+nullFunPtr = FunPtr nullAddr#++-- |Casts a 'FunPtr' to a 'FunPtr' of a different type.+castFunPtr :: FunPtr a -> FunPtr b+castFunPtr (FunPtr addr) = FunPtr addr++-- |Casts a 'FunPtr' to a 'Ptr'.+--+-- /Note:/ this is valid only on architectures where data and function+-- pointers range over the same set of addresses, and should only be used+-- for bindings to external libraries whose interface already relies on+-- this assumption.+castFunPtrToPtr :: FunPtr a -> Ptr b+castFunPtrToPtr (FunPtr addr) = Ptr addr++-- |Casts a 'Ptr' to a 'FunPtr'.+--+-- /Note:/ this is valid only on architectures where data and function+-- pointers range over the same set of addresses, and should only be used+-- for bindings to external libraries whose interface already relies on+-- this assumption.+castPtrToFunPtr :: Ptr a -> FunPtr b+castPtrToFunPtr (Ptr addr) = FunPtr addr+++------------------------------------------------------------------------+-- Show instances for Ptr and FunPtr+-- I have absolutely no idea why the WORD_SIZE_IN_BITS stuff is here++#if (WORD_SIZE == 4 || WORD_SIZE == 8)+#define SIZEOF_HSPTR WORD_SIZE+instance Show (Ptr a) where+   showsPrec _ (Ptr a) rs = pad_out (showHex (wordToInteger(int2Word#(addr2Int# a))) "")+     where+        -- want 0s prefixed to pad it out to a fixed length.+       pad_out ls = +          '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls ++ rs++instance Show (FunPtr a) where+   showsPrec p = showsPrec p . castFunPtrToPtr+#endif+\end{code}+
+ lib/base/src/GHC/Read.lhs view
@@ -0,0 +1,676 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Read+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Read' class and instances for basic data types.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Read+  ( Read(..)   -- class++  -- ReadS type+  , ReadS      -- :: *; = String -> [(a,String)]++  -- H98 compatibility+  , lex         -- :: ReadS String+  , lexLitChar  -- :: ReadS String+  , readLitChar -- :: ReadS Char+  , lexDigits   -- :: ReadS String++  -- defining readers+  , lexP       -- :: ReadPrec Lexeme+  , paren      -- :: ReadPrec a -> ReadPrec a+  , parens     -- :: ReadPrec a -> ReadPrec a+  , list       -- :: ReadPrec a -> ReadPrec [a]+  , choose     -- :: [(String, ReadPrec a)] -> ReadPrec a+  , readListDefault, readListPrecDefault++  -- Temporary+  , readParen++  -- XXX Can this be removed?+  , readp+  )+ where++import qualified Text.ParserCombinators.ReadP as P++import Text.ParserCombinators.ReadP+  ( ReadP+  , ReadS+  , readP_to_S+  )++import qualified Text.Read.Lex as L+-- Lex exports 'lex', which is also defined here,+-- hence the qualified import.+-- We can't import *anything* unqualified, because that+-- confuses Haddock.++import Text.ParserCombinators.ReadPrec++import Data.Maybe++#ifndef __HADDOCK__+import {-# SOURCE #-} GHC.Unicode       ( isDigit )+#endif+import GHC.Num+import GHC.Real+import GHC.Float ()+import GHC.Show+import GHC.Base+--import GHC.Arr+\end{code}+++\begin{code}+-- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with+-- parentheses.+--+-- @'readParen' 'False' p@ parses what @p@ parses, but optionally+-- surrounded with parentheses.+readParen       :: Bool -> ReadS a -> ReadS a+-- A Haskell 98 function+readParen b g   =  if b then mandatory else optional+                   where optional r  = g r ++ mandatory r+                         mandatory r = do+                                ("(",s) <- lex r+                                (x,t)   <- optional s+                                (")",u) <- lex t+                                return (x,u)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Read@ class}+%*                                                      *+%*********************************************************++\begin{code}+------------------------------------------------------------------------+-- class Read++-- | Parsing of 'String's, producing values.+--+-- Minimal complete definition: 'readsPrec' (or, for GHC only, 'readPrec')+--+-- Derived instances of 'Read' make the following assumptions, which+-- derived instances of 'Text.Show.Show' obey:+--+-- * If the constructor is defined to be an infix operator, then the+--   derived 'Read' instance will parse only infix applications of+--   the constructor (not the prefix form).+--+-- * Associativity is not used to reduce the occurrence of parentheses,+--   although precedence may be.+--+-- * If the constructor is defined using record syntax, the derived 'Read'+--   will parse only the record-syntax form, and furthermore, the fields+--   must be given in the same order as the original declaration.+--+-- * The derived 'Read' instance allows arbitrary Haskell whitespace+--   between tokens of the input string.  Extra parentheses are also+--   allowed.+--+-- For example, given the declarations+--+-- > infixr 5 :^:+-- > data Tree a =  Leaf a  |  Tree a :^: Tree a+--+-- the derived instance of 'Read' in Haskell 98 is equivalent to+--+-- > instance (Read a) => Read (Tree a) where+-- >+-- >         readsPrec d r =  readParen (d > app_prec)+-- >                          (\r -> [(Leaf m,t) |+-- >                                  ("Leaf",s) <- lex r,+-- >                                  (m,t) <- readsPrec (app_prec+1) s]) r+-- >+-- >                       ++ readParen (d > up_prec)+-- >                          (\r -> [(u:^:v,w) |+-- >                                  (u,s) <- readsPrec (up_prec+1) r,+-- >                                  (":^:",t) <- lex s,+-- >                                  (v,w) <- readsPrec (up_prec+1) t]) r+-- >+-- >           where app_prec = 10+-- >                 up_prec = 5+--+-- Note that right-associativity of @:^:@ is unused.+--+-- The derived instance in GHC is equivalent to+--+-- > instance (Read a) => Read (Tree a) where+-- >+-- >         readPrec = parens $ (prec app_prec $ do+-- >                                  Ident "Leaf" <- lexP+-- >                                  m <- step readPrec+-- >                                  return (Leaf m))+-- >+-- >                      +++ (prec up_prec $ do+-- >                                  u <- step readPrec+-- >                                  Symbol ":^:" <- lexP+-- >                                  v <- step readPrec+-- >                                  return (u :^: v))+-- >+-- >           where app_prec = 10+-- >                 up_prec = 5+-- >+-- >         readListPrec = readListPrecDefault++class Read a where+  -- | attempts to parse a value from the front of the string, returning+  -- a list of (parsed value, remaining string) pairs.  If there is no+  -- successful parse, the returned list is empty.+  --+  -- Derived instances of 'Read' and 'Text.Show.Show' satisfy the following:+  --+  -- * @(x,\"\")@ is an element of+  --   @('readsPrec' d ('Text.Show.showsPrec' d x \"\"))@.+  --+  -- That is, 'readsPrec' parses the string produced by+  -- 'Text.Show.showsPrec', and delivers the value that+  -- 'Text.Show.showsPrec' started with.++  readsPrec    :: Int   -- ^ the operator precedence of the enclosing+                        -- context (a number from @0@ to @11@).+                        -- Function application has precedence @10@.+                -> ReadS a++  -- | The method 'readList' is provided to allow the programmer to+  -- give a specialised way of parsing lists of values.+  -- For example, this is used by the predefined 'Read' instance of+  -- the 'Char' type, where values of type 'String' should be are+  -- expected to use double quotes, rather than square brackets.+  readList     :: ReadS [a]++  -- | Proposed replacement for 'readsPrec' using new-style parsers (GHC only).+  readPrec     :: ReadPrec a++  -- | Proposed replacement for 'readList' using new-style parsers (GHC only).+  -- The default definition uses 'readList'.  Instances that define 'readPrec'+  -- should also define 'readListPrec' as 'readListPrecDefault'.+  readListPrec :: ReadPrec [a]+  +  -- default definitions+  readsPrec    = readPrec_to_S readPrec+  readList     = readPrec_to_S (list readPrec) 0+  readPrec     = readS_to_Prec readsPrec+  readListPrec = readS_to_Prec (\_ -> readList)++readListDefault :: Read a => ReadS [a]+-- ^ A possible replacement definition for the 'readList' method (GHC only).+--   This is only needed for GHC, and even then only for 'Read' instances+--   where 'readListPrec' isn't defined as 'readListPrecDefault'.+readListDefault = readPrec_to_S readListPrec 0++readListPrecDefault :: Read a => ReadPrec [a]+-- ^ A possible replacement definition for the 'readListPrec' method,+--   defined using 'readPrec' (GHC only).+readListPrecDefault = list readPrec++------------------------------------------------------------------------+-- H98 compatibility++-- | The 'lex' function reads a single lexeme from the input, discarding+-- initial white space, and returning the characters that constitute the+-- lexeme.  If the input string contains only white space, 'lex' returns a+-- single successful \`lexeme\' consisting of the empty string.  (Thus+-- @'lex' \"\" = [(\"\",\"\")]@.)  If there is no legal lexeme at the+-- beginning of the input string, 'lex' fails (i.e. returns @[]@).+--+-- This lexer is not completely faithful to the Haskell lexical syntax+-- in the following respects:+--+-- * Qualified names are not handled properly+--+-- * Octal and hexadecimal numerics are not recognized as a single token+--+-- * Comments are not treated properly+lex :: ReadS String             -- As defined by H98+lex s  = readP_to_S L.hsLex s++-- | Read a string representation of a character, using Haskell+-- source-language escape conventions.  For example:+--+-- > lexLitChar  "\\nHello"  =  [("\\n", "Hello")]+--+lexLitChar :: ReadS String      -- As defined by H98+lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;+                              return s })+        -- There was a skipSpaces before the P.gather L.lexChar,+        -- but that seems inconsistent with readLitChar++-- | Read a string representation of a character, using Haskell+-- source-language escape conventions, and convert it to the character+-- that it encodes.  For example:+--+-- > readLitChar "\\nHello"  =  [('\n', "Hello")]+--+readLitChar :: ReadS Char       -- As defined by H98+readLitChar = readP_to_S L.lexChar++-- | Reads a non-empty string of decimal digits.+lexDigits :: ReadS String+lexDigits = readP_to_S (P.munch1 isDigit)++------------------------------------------------------------------------+-- utility parsers++lexP :: ReadPrec L.Lexeme+-- ^ Parse a single lexeme+lexP = lift L.lex++paren :: ReadPrec a -> ReadPrec a+-- ^ @(paren p)@ parses \"(P0)\"+--      where @p@ parses \"P0\" in precedence context zero+paren p = do L.Punc "(" <- lexP+             x          <- reset p+             L.Punc ")" <- lexP+             return x++parens :: ReadPrec a -> ReadPrec a+-- ^ @(parens p)@ parses \"P\", \"(P0)\", \"((P0))\", etc, +--      where @p@ parses \"P\"  in the current precedence context+--          and parses \"P0\" in precedence context zero+parens p = optional+ where+  optional  = p +++ mandatory+  mandatory = paren optional++list :: ReadPrec a -> ReadPrec [a]+-- ^ @(list p)@ parses a list of things parsed by @p@,+-- using the usual square-bracket syntax.+list readx =+  parens+  ( do L.Punc "[" <- lexP+       (listRest False +++ listNext)+  )+ where+  listRest started =+    do L.Punc c <- lexP+       case c of+         "]"           -> return []+         "," | started -> listNext+         _             -> pfail+  +  listNext =+    do x  <- reset readx+       xs <- listRest True+       return (x:xs)++choose :: [(String, ReadPrec a)] -> ReadPrec a+-- ^ Parse the specified lexeme and continue as specified.+-- Esp useful for nullary constructors; e.g.+--    @choose [(\"A\", return A), (\"B\", return B)]@+choose sps = foldr ((+++) . try_one) pfail sps+           where+             try_one (s,p) = do { L.Ident s' <- lexP ;+                                  if s == s' then p else pfail }+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Simple instances of Read}+%*                                                      *+%*********************************************************++\begin{code}+instance Read Char where+  readPrec =+    parens+    ( do L.Char c <- lexP+         return c+    )++  readListPrec =+    parens+    ( do L.String s <- lexP     -- Looks for "foo"+         return s+     ++++      readListPrecDefault       -- Looks for ['f','o','o']+    )                           -- (more generous than H98 spec)++  readList = readListDefault++instance Read Bool where+  readPrec =+    parens+    ( do L.Ident s <- lexP+         case s of+           "True"  -> return True+           "False" -> return False+           _       -> pfail+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Ordering where+  readPrec =+    parens+    ( do L.Ident s <- lexP+         case s of+           "LT" -> return LT+           "EQ" -> return EQ+           "GT" -> return GT+           _    -> pfail+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Structure instances of Read: Maybe, List etc}+%*                                                      *+%*********************************************************++For structured instances of Read we start using the precedences.  The+idea is then that 'parens (prec k p)' will fail immediately when trying+to parse it in a context with a higher precedence level than k. But if+there is one parenthesis parsed, then the required precedence level+drops to 0 again, and parsing inside p may succeed.++'appPrec' is just the precedence level of function application.  So,+if we are parsing function application, we'd better require the+precedence level to be at least 'appPrec'. Otherwise, we have to put+parentheses around it.++'step' is used to increase the precedence levels inside a+parser, and can be used to express left- or right- associativity. For+example, % is defined to be left associative, so we only increase+precedence on the right hand side.++Note how step is used in for example the Maybe parser to increase the+precedence beyond appPrec, so that basically only literals and+parenthesis-like objects such as (...) and [...] can be an argument to+'Just'.++\begin{code}+instance Read a => Read (Maybe a) where+  readPrec =+    parens+    (do L.Ident "Nothing" <- lexP+        return Nothing+     ++++     prec appPrec (+        do L.Ident "Just" <- lexP+           x              <- step readPrec+           return (Just x))+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read a => Read [a] where+  readPrec     = readListPrec+  readListPrec = readListPrecDefault+  readList     = readListDefault+{-+instance  (Ix a, Read a, Read b) => Read (Array a b)  where+    readPrec = parens $ prec appPrec $+               do L.Ident "array" <- lexP+                  theBounds <- step readPrec+                  vals   <- step readPrec+                  return (array theBounds vals)++    readListPrec = readListPrecDefault+    readList     = readListDefault+-}+instance Read L.Lexeme where+  readPrec     = lexP+  readListPrec = readListPrecDefault+  readList     = readListDefault+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Numeric instances of Read}+%*                                                      *+%*********************************************************++\begin{code}+readNumber :: Num a => (L.Lexeme -> Maybe a) -> ReadPrec a+-- Read a signed number+readNumber convert =+  parens+  ( do x <- lexP+       case x of+         L.Symbol "-" -> do n <- readNumber convert+                            return (negate n)+       +         _   -> case convert x of+                   Just n  -> return n+                   Nothing -> pfail+  )++convertInt :: Num a => L.Lexeme -> Maybe a+convertInt (L.Int i) = Just (fromInteger i)+convertInt _         = Nothing++convertFrac :: Fractional a => L.Lexeme -> Maybe a+convertFrac (L.Int i) = Just (fromInteger i)+convertFrac (L.Rat r) = Just (fromRational r)+convertFrac _         = Nothing++instance Read Int where+  readPrec     = readNumber convertInt+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Integer where+  readPrec     = readNumber convertInt+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Float where+  readPrec     = readNumber convertFrac+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Double where+  readPrec     = readNumber convertFrac+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Integral a, Read a) => Read (Ratio a) where+  readPrec =+    parens+    ( prec ratioPrec+      ( do x            <- step readPrec+           L.Symbol "%" <- lexP+           y            <- step readPrec+           return (x % y)+      )+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault+\end{code}+++%*********************************************************+%*                                                      *+        Tuple instances of Read, up to size 15+%*                                                      *+%*********************************************************++\begin{code}+instance Read () where+  readPrec =+    parens+    ( paren+      ( return ()+      )+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b) => Read (a,b) where+  readPrec = wrap_tup read_tup2+  readListPrec = readListPrecDefault+  readList     = readListDefault++wrap_tup :: ReadPrec a -> ReadPrec a+wrap_tup p = parens (paren p)++read_comma :: ReadPrec ()+read_comma = do { L.Punc "," <- lexP; return () }++read_tup2 :: (Read a, Read b) => ReadPrec (a,b)+-- Reads "a , b"  no parens!+read_tup2 = do x <- readPrec+               read_comma+               y <- readPrec+               return (x,y)++read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d)+read_tup4 = do  (a,b) <- read_tup2+                read_comma+                (c,d) <- read_tup2+                return (a,b,c,d)+++read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)+          => ReadPrec (a,b,c,d,e,f,g,h)+read_tup8 = do  (a,b,c,d) <- read_tup4+                read_comma+                (e,f,g,h) <- read_tup4+                return (a,b,c,d,e,f,g,h)+++instance (Read a, Read b, Read c) => Read (a, b, c) where+  readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma +                          ; c <- readPrec +                          ; return (a,b,c) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where+  readPrec = wrap_tup read_tup4+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where+  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma+                          ; e <- readPrec+                          ; return (a,b,c,d,e) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f)+        => Read (a, b, c, d, e, f) where+  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma+                          ; (e,f) <- read_tup2+                          ; return (a,b,c,d,e,f) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g)+        => Read (a, b, c, d, e, f, g) where+  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma+                          ; (e,f) <- read_tup2; read_comma+                          ; g <- readPrec+                          ; return (a,b,c,d,e,f,g) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)+        => Read (a, b, c, d, e, f, g, h) where+  readPrec     = wrap_tup read_tup8+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i)+        => Read (a, b, c, d, e, f, g, h, i) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; i <- readPrec+                          ; return (a,b,c,d,e,f,g,h,i) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i, Read j)+        => Read (a, b, c, d, e, f, g, h, i, j) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; (i,j) <- read_tup2+                          ; return (a,b,c,d,e,f,g,h,i,j) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i, Read j, Read k)+        => Read (a, b, c, d, e, f, g, h, i, j, k) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; (i,j) <- read_tup2; read_comma+                          ; k <- readPrec+                          ; return (a,b,c,d,e,f,g,h,i,j,k) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i, Read j, Read k, Read l)+        => Read (a, b, c, d, e, f, g, h, i, j, k, l) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; (i,j,k,l) <- read_tup4+                          ; return (a,b,c,d,e,f,g,h,i,j,k,l) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i, Read j, Read k, Read l, Read m)+        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; (i,j,k,l) <- read_tup4; read_comma+                          ; m <- readPrec+                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i, Read j, Read k, Read l, Read m, Read n)+        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; (i,j,k,l) <- read_tup4; read_comma+                          ; (m,n) <- read_tup2+                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,+          Read i, Read j, Read k, Read l, Read m, Read n, Read o)+        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma+                          ; (i,j,k,l) <- read_tup4; read_comma+                          ; (m,n) <- read_tup2; read_comma+                          ; o <- readPrec+                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })+  readListPrec = readListPrecDefault+  readList     = readListDefault+\end{code}++\begin{code}+-- XXX Can this be removed?++readp :: Read a => ReadP a+readp = readPrec_to_P readPrec minPrec+\end{code}+
+ lib/base/src/GHC/Real.lhs view
@@ -0,0 +1,481 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Real+-- Copyright   :  (c) The FFI Task Force, 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The types 'Ratio' and 'Rational', and the classes 'Real', 'Fractional',+-- 'Integral', and 'RealFrac'.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Real where++import GHC.Base+import GHC.Num+import GHC.List+import GHC.Enum+import GHC.Show++infixr 8  ^, ^^+infixl 7  /, `quot`, `rem`, `div`, `mod`+infixl 7  %++default ()              -- Double isn't available yet, +                        -- and we shouldn't be using defaults anyway+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Ratio@ and @Rational@ types}+%*                                                      *+%*********************************************************++\begin{code}+-- | Rational numbers, with numerator and denominator of some 'Integral' type.+data  (Integral a)      => Ratio a = !a :% !a  deriving (Eq)++-- | Arbitrary-precision rational numbers, represented as a ratio of+-- two 'Integer' values.  A rational number may be constructed using+-- the '%' operator.+type  Rational          =  Ratio Integer++ratioPrec, ratioPrec1 :: Int+ratioPrec  = 7  -- Precedence of ':%' constructor+ratioPrec1 = ratioPrec + 1++infinity, notANumber :: Rational+infinity   = 1 :% 0+notANumber = 0 :% 0++-- Use :%, not % for Inf/NaN; the latter would +-- immediately lead to a runtime error, because it normalises. +\end{code}+++\begin{code}+-- | Forms the ratio of two integral numbers.+{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}+(%)                     :: (Integral a) => a -> a -> Ratio a++-- | Extract the numerator of the ratio in reduced form:+-- the numerator and denominator have no common factor and the denominator+-- is positive.+numerator       :: (Integral a) => Ratio a -> a++-- | Extract the denominator of the ratio in reduced form:+-- the numerator and denominator have no common factor and the denominator+-- is positive.+denominator     :: (Integral a) => Ratio a -> a+\end{code}++\tr{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.++\begin{code}+reduce ::  (Integral a) => a -> a -> Ratio a+{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}+reduce _ 0              =  error "Ratio.%: zero denominator"+reduce x y              =  (x `quot` d) :% (y `quot` d)+                           where d = gcd x y+\end{code}++\begin{code}+x % y                   =  reduce (x * signum y) (abs y)++numerator   (x :% _)    =  x+denominator (_ :% y)    =  y+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Standard numeric classes}+%*                                                      *+%*********************************************************++\begin{code}+class  (Num a, Ord a) => Real a  where+    -- | the rational equivalent of its real argument with full precision+    toRational          ::  a -> Rational++-- | Integral numbers, supporting integer division.+--+-- Minimal complete definition: 'quotRem' and 'toInteger'+class  (Real a, Enum a) => Integral a  where+    -- | integer division truncated toward zero+    quot                :: a -> a -> a+    -- | integer remainder, satisfying+    --+    -- > (x `quot` y)*y + (x `rem` y) == x+    rem                 :: a -> a -> a+    -- | integer division truncated toward negative infinity+    div                 :: a -> a -> a+    -- | integer modulus, satisfying+    --+    -- > (x `div` y)*y + (x `mod` y) == x+    mod                 :: a -> a -> a+    -- | simultaneous 'quot' and 'rem'+    quotRem             :: a -> a -> (a,a)+    -- | simultaneous 'div' and 'mod'+    divMod              :: a -> a -> (a,a)+    -- | conversion to 'Integer'+    toInteger           :: a -> Integer++    n `quot` d          =  q  where (q,_) = quotRem n d+    n `rem` d           =  r  where (_,r) = quotRem n d+    n `div` d           =  q  where (q,_) = divMod n d+    n `mod` d           =  r  where (_,r) = divMod n d+    divMod n d          =  if signum r == negate (signum d) then (q-1, r+d) else qr+                           where qr@(q,r) = quotRem n d++-- | Fractional numbers, supporting real division.+--+-- Minimal complete definition: 'fromRational' and ('recip' or @('/')@)+class  (Num a) => Fractional a  where+    -- | fractional division+    (/)                 :: a -> a -> a+    -- | reciprocal fraction+    recip               :: a -> a+    -- | Conversion from a 'Rational' (that is @'Ratio' 'Integer'@).+    -- A floating literal stands for an application of 'fromRational'+    -- to a value of type 'Rational', so such literals have type+    -- @('Fractional' a) => a@.+    fromRational        :: Rational -> a++    recip x             =  1 / x+    x / y               = x * recip y++-- | Extracting components of fractions.+--+-- Minimal complete definition: 'properFraction'+class  (Real a, Fractional a) => RealFrac a  where+    -- | The function 'properFraction' takes a real fractional number @x@+    -- and returns a pair @(n,f)@ such that @x = n+f@, and:+    --+    -- * @n@ is an integral number with the same sign as @x@; and+    --+    -- * @f@ is a fraction with the same type and sign as @x@,+    --   and with absolute value less than @1@.+    --+    -- The default definitions of the 'ceiling', 'floor', 'truncate'+    -- and 'round' functions are in terms of 'properFraction'.+    properFraction      :: (Integral b) => a -> (b,a)+    -- | @'truncate' x@ returns the integer nearest @x@ between zero and @x@+    truncate            :: (Integral b) => a -> b+    -- | @'round' x@ returns the nearest integer to @x@;+    --   the even integer if @x@ is equidistant between two integers+    round               :: (Integral b) => a -> b+    -- | @'ceiling' x@ returns the least integer not less than @x@+    ceiling             :: (Integral b) => a -> b+    -- | @'floor' x@ returns the greatest integer not greater than @x@+    floor               :: (Integral b) => a -> b++    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 - 0.5) of+                                -1 -> n+                                0  -> if even n then n else m+                                1  -> m+                                _  -> error "round default defn: Bad value"+    +    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+\end{code}+++These 'numeric' enumerations come straight from the Report++\begin{code}+numericEnumFrom         :: (Fractional a) => a -> [a]+numericEnumFrom n	=  n `seq` (n : numericEnumFrom (n + 1))++numericEnumFromThen     :: (Fractional a) => a -> a -> [a]+numericEnumFromThen n m	= n `seq` m `seq` (n : numericEnumFromThen m (m+m-n))++numericEnumFromTo       :: (Ord a, Fractional a) => a -> a -> [a]+numericEnumFromTo n m   = takeWhile (<= m + 1/2) (numericEnumFrom n)++numericEnumFromThenTo   :: (Ord a, Fractional a) => a -> a -> a -> [a]+numericEnumFromThenTo e1 e2 e3+    = takeWhile predicate (numericEnumFromThen e1 e2)+                                where+                                 mid = (e2 - e1) / 2+                                 predicate | e2 >= e1  = (<= e3 + mid)+                                           | otherwise = (>= e3 + mid)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Int@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Real Int  where+    toRational x        =  toInteger x % 1++instance  Integral Int  where+    toInteger (I# i) = smallInteger i++    a `quot` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `quotInt` b++    a `rem` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `remInt` b++    a `div` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `divInt` b++    a `mod` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `modInt` b++    a `quotRem` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `quotRemInt` b++    a `divMod` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `divModInt` b+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Integer@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Real Integer  where+    toRational x        =  x % 1++instance  Integral Integer where+    toInteger n      = n++    _ `quot` 0 = divZeroError+    n `quot` d = n `quotInteger` d++    _ `rem` 0 = divZeroError+    n `rem`  d = n `remInteger`  d++    _ `divMod` 0 = divZeroError+    a `divMod` b = case a `divModInteger` b of+                   (# x, y #) -> (x, y)++    _ `quotRem` 0 = divZeroError+    a `quotRem` b = case a `quotRemInteger` b of+                    (# q, r #) -> (q, r)++    -- use the defaults for div & mod+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Ratio@}+%*                                                      *+%*********************************************************++\begin{code}+instance  (Integral a)  => Ord (Ratio a)  where+    {-# SPECIALIZE instance Ord Rational #-}+    (x:%y) <= (x':%y')  =  x * y' <= x' * y+    (x:%y) <  (x':%y')  =  x * y' <  x' * y++instance  (Integral a)  => Num (Ratio a)  where+    {-# SPECIALIZE instance Num Rational #-}+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')+    (x:%y) - (x':%y')   =  reduce (x*y' - x'*y) (y*y')+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')+    negate (x:%y)       =  (-x) :% y+    abs (x:%y)          =  abs x :% y+    signum (x:%_)       =  signum x :% 1+    fromInteger x       =  fromInteger x :% 1++instance  (Integral a)  => Fractional (Ratio a)  where+    {-# SPECIALIZE instance Fractional Rational #-}+    (x:%y) / (x':%y')   =  (x*y') % (y*x')+    recip (x:%y)        =  y % x+    fromRational (x:%y) =  fromInteger x :% fromInteger y++instance  (Integral a)  => Real (Ratio a)  where+    {-# SPECIALIZE instance Real Rational #-}+    toRational (x:%y)   =  toInteger x :% toInteger y++instance  (Integral a)  => RealFrac (Ratio a)  where+    {-# SPECIALIZE instance RealFrac Rational #-}+    properFraction (x:%y) = (fromInteger (toInteger q), r:%y)+                          where (q,r) = quotRem x y++instance  (Integral a)  => Show (Ratio a)  where+    {-# SPECIALIZE instance Show Rational #-}+    showsPrec p (x:%y)  =  showParen (p > ratioPrec) $+                           showsPrec ratioPrec1 x . +                           showString " % " .+                           -- H98 report has spaces round the %+                           -- but we removed them [May 04]+                           -- and added them again for consistency with+                           -- Haskell 98 [Sep 08, #1920]+                           showsPrec ratioPrec1 y++instance  (Integral a)  => Enum (Ratio a)  where+    {-# SPECIALIZE instance Enum Rational #-}+    succ x              =  x + 1+    pred x              =  x - 1++    toEnum n            =  fromIntegral n :% 1+    fromEnum            =  fromInteger . truncate++    enumFrom            =  numericEnumFrom+    enumFromThen        =  numericEnumFromThen+    enumFromTo          =  numericEnumFromTo+    enumFromThenTo      =  numericEnumFromThenTo+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Coercions}+%*                                                      *+%*********************************************************++\begin{code}+-- | general coercion from integral types+fromIntegral :: (Integral a, Num b) => a -> b+fromIntegral = fromInteger . toInteger++{-# RULES+"fromIntegral/Int->Int" fromIntegral = id :: Int -> Int+    #-}++-- | general coercion to fractional types+realToFrac :: (Real a, Fractional b) => a -> b+realToFrac = fromRational . toRational++{-# RULES+"realToFrac/Int->Int" realToFrac = id :: Int -> Int+    #-}+\end{code}++%*********************************************************+%*                                                      *+\subsection{Overloaded numeric functions}+%*                                                      *+%*********************************************************++\begin{code}+-- | Converts a possibly-negative 'Real' value to a string.+showSigned :: (Real a)+  => (a -> ShowS)       -- ^ a function that can show unsigned values+  -> Int                -- ^ the precedence of the enclosing context+  -> a                  -- ^ the value to show+  -> ShowS+showSigned showPos p x +   | x < 0     = showParen (p > 6) (showChar '-' . showPos (-x))+   | otherwise = showPos x++even, odd       :: (Integral a) => a -> Bool+even n          =  n `rem` 2 == 0+odd             =  not . even++-------------------------------------------------------+-- | raise a number to a non-negative integral power+{-# SPECIALISE (^) ::+        Integer -> Integer -> Integer,+        Integer -> Int -> Integer,+        Int -> Int -> Int #-}+(^) :: (Num a, Integral b) => a -> b -> a+x0 ^ y0 | y0 < 0    = error "Negative exponent"+        | y0 == 0   = 1+        | otherwise = f x0 y0+    where -- f : x0 ^ y0 = x ^ y+          f x y | even y    = f (x * x) (y `quot` 2)+                | y == 1    = x+                | otherwise = g (x * x) ((y - 1) `quot` 2) x+          -- g : x0 ^ y0 = (x ^ y) * z+          g x y z | even y = g (x * x) (y `quot` 2) z+                  | y == 1 = x * z+                  | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z)++-- | raise a number to an integral power+{-# SPECIALISE (^^) ::+        Rational -> Int -> Rational #-}+(^^)            :: (Fractional a, Integral b) => a -> b -> a+x ^^ n          =  if n >= 0 then x^n else recip (x^(negate n))+++-------------------------------------------------------+-- | @'gcd' x y@ is the greatest (positive) integer that divides both @x@+-- and @y@; for example @'gcd' (-3) 6@ = @3@, @'gcd' (-3) (-6)@ = @3@,+-- @'gcd' 0 4@ = @4@.  @'gcd' 0 0@ raises a runtime error.+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' a 0  =  a+                         gcd' a b  =  gcd' b (a `rem` b)++-- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.+lcm             :: (Integral a) => a -> a -> a+{-# SPECIALISE lcm :: Int -> Int -> Int #-}+lcm _ 0         =  0+lcm 0 _         =  0+lcm x y         =  abs ((x `quot` (gcd x y)) * y)++{-# RULES+"gcd/Int->Int->Int"             gcd = gcdInt+"gcd/Integer->Integer->Integer" gcd = gcdInteger'+"lcm/Integer->Integer->Integer" lcm = lcmInteger+ #-}++-- XXX to use another Integer implementation, you might need to disable+-- the gcd/Integer and lcm/Integer RULES above+--+gcdInteger' :: Integer -> Integer -> Integer+gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined"+gcdInteger' a b = gcdInteger a b++integralEnumFrom :: (Integral a, Bounded a) => a -> [a]+integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)]++integralEnumFromThen :: (Integral a, Bounded a) => a -> a -> [a]+integralEnumFromThen n1 n2+  | i_n2 >= i_n1  = map fromInteger [i_n1, i_n2 .. toInteger (maxBound `asTypeOf` n1)]+  | otherwise     = map fromInteger [i_n1, i_n2 .. toInteger (minBound `asTypeOf` n1)]+  where+    i_n1 = toInteger n1+    i_n2 = toInteger n2++integralEnumFromTo :: Integral a => a -> a -> [a]+integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m]++integralEnumFromThenTo :: Integral a => a -> a -> a -> [a]+integralEnumFromThenTo n1 n2 m+  = map fromInteger [toInteger n1, toInteger n2 .. toInteger m]+\end{code}
+ lib/base/src/GHC/ST.lhs view
@@ -0,0 +1,165 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.ST+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'ST' Monad.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.ST where++import GHC.Base+import GHC.Show+import GHC.Num++default ()+\end{code}++%*********************************************************+%*                                                      *+\subsection{The @ST@ monad}+%*                                                      *+%*********************************************************++The state-transformer monad proper.  By default the monad is strict;+too many people got bitten by space leaks when it was lazy.++\begin{code}+-- | The strict state-transformer monad.+-- A computation of type @'ST' s a@ transforms an internal state indexed+-- by @s@, and returns a value of type @a@.+-- The @s@ parameter is either+--+-- * an uninstantiated type variable (inside invocations of 'runST'), or+--+-- * 'RealWorld' (inside invocations of 'Control.Monad.ST.stToIO').+--+-- It serves to keep the internal states of different invocations+-- of 'runST' separate from each other and from invocations of+-- 'Control.Monad.ST.stToIO'.+--+-- The '>>=' and '>>' operations are strict in the state (though not in+-- values stored in the state).  For example,+--+-- @'runST' (writeSTRef _|_ v >>= f) = _|_@+newtype ST s a = ST (STRep s a)+type STRep s a = State# s -> (# State# s, a #)++instance Functor (ST s) where+    fmap f (ST m) = ST $ \ s ->+      case (m s) of { (# new_s, r #) ->+      (# new_s, f r #) }++instance Monad (ST s) where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    return x = ST (\ s -> (# s, x #))+    m >> k   = m >>= \ _ -> k++    (ST m) >>= k+      = ST (\ s ->+        case (m s) of { (# new_s, r #) ->+        case (k r) of { ST k2 ->+        (k2 new_s) }})++data STret s a = STret (State# s) a++-- liftST is useful when we want a lifted result from an ST computation.  See+-- fixST below.+liftST :: ST s a -> State# s -> STret s a+liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r++{-# NOINLINE unsafeInterleaveST #-}+unsafeInterleaveST :: ST s a -> ST s a+unsafeInterleaveST (ST m) = ST ( \ s ->+    let+        r = case m s of (# _, res #) -> res+    in+    (# s, r #)+  )++-- | Allow the result of a state transformer computation to be used (lazily)+-- inside the computation.+-- Note that if @f@ is strict, @'fixST' f = _|_@.+fixST :: (a -> ST s a) -> ST s a+fixST k = ST $ \ s ->+    let ans       = liftST (k r) s+        STret _ r = ans+    in+    case ans of STret s' x -> (# s', x #)++instance  Show (ST s a)  where+    showsPrec _ _  = showString "<<ST action>>"+    showList       = showList__ (showsPrec 0)+\end{code}++Definition of runST+~~~~~~~~~~~~~~~~~~~++SLPJ 95/04: Why @runST@ must not have an unfolding; consider:+\begin{verbatim}+f x =+  runST ( \ s -> let+                    (a, s')  = newArray# 100 [] s+                    (_, s'') = fill_in_array_or_something a x s'+                  in+                  freezeArray# a s'' )+\end{verbatim}+If we inline @runST@, we'll get:+\begin{verbatim}+f x = let+        (a, s')  = newArray# 100 [] realWorld#{-NB-}+        (_, s'') = fill_in_array_or_something a x s'+      in+      freezeArray# a s''+\end{verbatim}+And now the @newArray#@ binding can be floated to become a CAF, which+is totally and utterly wrong:+\begin{verbatim}+f = let+    (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!+    in+    \ x ->+        let (_, s'') = fill_in_array_or_something a x s' in+        freezeArray# a s''+\end{verbatim}+All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.++\begin{code}+{-# INLINE runST #-}+-- The INLINE prevents runSTRep getting inlined in *this* module+-- so that it is still visible when runST is inlined in an importing+-- module.  Regrettably delicate.  runST is behaving like a wrapper.++-- | Return the value computed by a state transformer computation.+-- The @forall@ ensures that the internal state used by the 'ST'+-- computation is inaccessible to the rest of the program.+runST :: (forall s. ST s a) -> a+runST st = runSTRep (case st of { ST st_rep -> st_rep })++-- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness+-- That's what the "INLINE [0]" says.+--              SLPJ Apr 99+-- {-# INLINE [0] runSTRep #-}++-- SDM: further to the above, inline phase 0 is run *before*+-- full-laziness at the moment, which means that the above comment is+-- invalid.  Inlining runSTRep doesn't make a huge amount of+-- difference, anyway.  Hence:++{-# NOINLINE runSTRep #-}+runSTRep :: (forall s. STRep s a) -> a+runSTRep st_rep = case st_rep realWorld# of+                        (# _, r #) -> r+\end{code}
+ lib/base/src/GHC/STRef.lhs view
@@ -0,0 +1,47 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.STRef+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- References in the 'ST' monad.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.STRef where++import GHC.ST+import GHC.Base++data STRef s a = STRef (MutVar# s a)+-- ^ a value of type @STRef s a@ is a mutable variable in state thread @s@,+-- containing a value of type @a@++-- |Build a new 'STRef' in the current state thread+newSTRef :: a -> ST s (STRef s a)+newSTRef init = ST $ \s1# ->+    case newMutVar# init s1#            of { (# s2#, var# #) ->+    (# s2#, STRef var# #) }++-- |Read the value of an 'STRef'+readSTRef :: STRef s a -> ST s a+readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1#++-- |Write a new value into an 'STRef'+writeSTRef :: STRef s a -> a -> ST s ()+writeSTRef (STRef var#) val = ST $ \s1# ->+    case writeMutVar# var# val s1#      of { s2# ->+    (# s2#, () #) }++-- Just pointer equality on mutable references:+instance Eq (STRef s a) where+    STRef v1# == STRef v2# = sameMutVar# v1# v2#+\end{code}
+ lib/base/src/GHC/Show.lhs view
@@ -0,0 +1,404 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Show+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Show' class, and related operations.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Show+        (+        Show(..), ShowS,++        -- Instances for Show: (), [], Bool, Ordering, Int, Char++        -- Show support code+        shows, showChar, showString, showParen, showList__, showSpace,+        showLitChar, protectEsc,+        intToDigit, showSignedInt,+        appPrec, appPrec1,++        -- Character operations+        asciiTab,+  )+        where++import GHC.Base+import Data.Maybe+import GHC.List ((!!), foldr1)+\end{code}++++%*********************************************************+%*                                                      *+\subsection{The @Show@ class}+%*                                                      *+%*********************************************************++\begin{code}+-- | The @shows@ functions return a function that prepends the+-- output 'String' to an existing 'String'.  This allows constant-time+-- concatenation of results using function composition.+type ShowS = String -> String++-- | Conversion of values to readable 'String's.+--+-- Minimal complete definition: 'showsPrec' or 'show'.+--+-- Derived instances of 'Show' have the following properties, which+-- are compatible with derived instances of 'Text.Read.Read':+--+-- * The result of 'show' is a syntactically correct Haskell+--   expression containing only constants, given the fixity+--   declarations in force at the point where the type is declared.+--   It contains only the constructor names defined in the data type,+--   parentheses, and spaces.  When labelled constructor fields are+--   used, braces, commas, field names, and equal signs are also used.+--+-- * If the constructor is defined to be an infix operator, then+--   'showsPrec' will produce infix applications of the constructor.+--+-- * the representation will be enclosed in parentheses if the+--   precedence of the top-level constructor in @x@ is less than @d@+--   (associativity is ignored).  Thus, if @d@ is @0@ then the result+--   is never surrounded in parentheses; if @d@ is @11@ it is always+--   surrounded in parentheses, unless it is an atomic expression.+--+-- * If the constructor is defined using record syntax, then 'show'+--   will produce the record-syntax form, with the fields given in the+--   same order as the original declaration.+--+-- For example, given the declarations+--+-- > infixr 5 :^:+-- > data Tree a =  Leaf a  |  Tree a :^: Tree a+--+-- the derived instance of 'Show' is equivalent to+--+-- > instance (Show a) => Show (Tree a) where+-- >+-- >        showsPrec d (Leaf m) = showParen (d > app_prec) $+-- >             showString "Leaf " . showsPrec (app_prec+1) m+-- >          where app_prec = 10+-- >+-- >        showsPrec d (u :^: v) = showParen (d > up_prec) $+-- >             showsPrec (up_prec+1) u . +-- >             showString " :^: "      .+-- >             showsPrec (up_prec+1) v+-- >          where up_prec = 5+--+-- Note that right-associativity of @:^:@ is ignored.  For example,+--+-- * @'show' (Leaf 1 :^: Leaf 2 :^: Leaf 3)@ produces the string+--   @\"Leaf 1 :^: (Leaf 2 :^: Leaf 3)\"@.++class  Show a  where+    -- | Convert a value to a readable 'String'.+    --+    -- 'showsPrec' should satisfy the law+    --+    -- > showsPrec d x r ++ s  ==  showsPrec d x (r ++ s)+    --+    -- Derived instances of 'Text.Read.Read' and 'Show' satisfy the following:+    --+    -- * @(x,\"\")@ is an element of+    --   @('Text.Read.readsPrec' d ('showsPrec' d x \"\"))@.+    --+    -- That is, 'Text.Read.readsPrec' parses the string produced by+    -- 'showsPrec', and delivers the value that 'showsPrec' started with.++    showsPrec :: Int    -- ^ the operator precedence of the enclosing+                        -- context (a number from @0@ to @11@).+                        -- Function application has precedence @10@.+              -> a      -- ^ the value to be converted to a 'String'+              -> ShowS++    -- | A specialised variant of 'showsPrec', using precedence context+    -- zero, and returning an ordinary 'String'.+    show      :: a   -> String++    -- | The method 'showList' is provided to allow the programmer to+    -- give a specialised way of showing lists of values.+    -- For example, this is used by the predefined 'Show' instance of+    -- the 'Char' type, where values of type 'String' should be shown+    -- in double quotes, rather than between square brackets.+    showList  :: [a] -> ShowS++    showsPrec _ x s = show x ++ s+    show x          = shows x ""+    showList ls   s = showList__ shows ls s++showList__ :: (a -> ShowS) ->  [a] -> ShowS+showList__ _     []     s = "[]" ++ s+showList__ showx (x:xs) s = '[' : showx x (showl xs)+  where+    showl []     = ']' : s+    showl (y:ys) = ',' : showx y (showl ys)++appPrec, appPrec1 :: Int+        -- Use unboxed stuff because we don't have overloaded numerics yet+appPrec = I# 10#        -- Precedence of application:+                        --   one more than the maximum operator precedence of 9+appPrec1 = I# 11#       -- appPrec + 1+\end{code}++%*********************************************************+%*                                                      *+\subsection{Simple Instances}+%*                                                      *+%*********************************************************++\begin{code}+ +instance  Show ()  where+    showsPrec _ () = showString "()"++instance Show a => Show [a]  where+    showsPrec _         = showList++instance Show Bool where+  showsPrec _ True  = showString "True"+  showsPrec _ False = showString "False"++instance Show Ordering where+  showsPrec _ LT = showString "LT"+  showsPrec _ EQ = showString "EQ"+  showsPrec _ GT = showString "GT"++instance  Show Char  where+    showsPrec _ '\'' = showString "'\\''"+    showsPrec _ c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs = showChar '"' . showl cs+                 where showl ""       s = showChar '"' s+                       showl ('"':xs) s = showString "\\\"" (showl xs s)+                       showl (x:xs)   s = showLitChar x (showl xs s)+                -- Making 's' an explicit parameter makes it clear to GHC+                -- that showl has arity 2, which avoids it allocating an extra lambda+                -- The sticking point is the recursive call to (showl xs), which+                -- it can't figure out would be ok with arity 2.++instance Show Int where+    showsPrec = showSignedInt++instance Show a => Show (Maybe a) where+    showsPrec _p Nothing s = showString "Nothing" s+    showsPrec p (Just x) s+                          = (showParen (p > appPrec) $ +                             showString "Just " . +                             showsPrec appPrec1 x) s+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Show instances for the first few tuples+%*                                                      *+%*********************************************************++\begin{code}+-- The explicit 's' parameters are important+-- Otherwise GHC thinks that "shows x" might take a lot of work to compute+-- and generates defns like+--      showsPrec _ (x,y) = let sx = shows x; sy = shows y in+--                          \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s))))++instance  (Show a, Show b) => Show (a,b)  where+  showsPrec _ (a,b) s = show_tuple [shows a, shows b] s++instance (Show a, Show b, Show c) => Show (a, b, c) where+  showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s++instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where+  showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s++instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where+  showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s++instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where+  showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)+        => Show (a,b,c,d,e,f,g) where+  showsPrec _ (a,b,c,d,e,f,g) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)+         => Show (a,b,c,d,e,f,g,h) where+  showsPrec _ (a,b,c,d,e,f,g,h) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i)+         => Show (a,b,c,d,e,f,g,h,i) where+  showsPrec _ (a,b,c,d,e,f,g,h,i) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j)+         => Show (a,b,c,d,e,f,g,h,i,j) where+  showsPrec _ (a,b,c,d,e,f,g,h,i,j) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i, shows j] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k)+         => Show (a,b,c,d,e,f,g,h,i,j,k) where+  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i, shows j, shows k] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,+          Show l)+         => Show (a,b,c,d,e,f,g,h,i,j,k,l) where+  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i, shows j, shows k, shows l] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,+          Show l, Show m)+         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where+  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i, shows j, shows k, shows l, shows m] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,+          Show l, Show m, Show n)+         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i, shows j, shows k, shows l, shows m, shows n] s++instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,+          Show l, Show m, Show n, Show o)+         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s +        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +                      shows i, shows j, shows k, shows l, shows m, shows n, shows o] s++show_tuple :: [ShowS] -> ShowS+show_tuple ss = showChar '('+              . foldr1 (\s r -> s . showChar ',' . r) ss+              . showChar ')'+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Support code for @Show@}+%*                                                      *+%*********************************************************++\begin{code}+-- | equivalent to 'showsPrec' with a precedence of 0.+shows           :: (Show a) => a -> ShowS+shows           =  showsPrec zeroInt++-- | utility function converting a 'Char' to a show function that+-- simply prepends the character unchanged.+showChar        :: Char -> ShowS+showChar        =  (:)++-- | utility function converting a 'String' to a show function that+-- simply prepends the string unchanged.+showString      :: String -> ShowS+showString      =  (++)++-- | utility function that surrounds the inner show function with+-- parentheses when the 'Bool' parameter is 'True'.+showParen       :: Bool -> ShowS -> ShowS+showParen b p   =  if b then showChar '(' . p . showChar ')' else p++showSpace :: ShowS+showSpace = {-showChar ' '-} \ xs -> ' ' : xs+\end{code}++Code specific for characters++\begin{code}+-- | Convert a character to a string using only printable characters,+-- using Haskell source-language escape conventions.  For example:+--+-- > showLitChar '\n' s  =  "\\n" ++ s+--+showLitChar                :: Char -> ShowS+showLitChar c s | c > '\DEL' =  showChar '\\' (protectEsc isDec (shows (ord c)) s)+showLitChar '\DEL'         s =  showString "\\DEL" s+showLitChar '\\'           s =  showString "\\\\" s+showLitChar c s | c >= ' '   =  showChar c s+showLitChar '\a'           s =  showString "\\a" s+showLitChar '\b'           s =  showString "\\b" s+showLitChar '\f'           s =  showString "\\f" s+showLitChar '\n'           s =  showString "\\n" s+showLitChar '\r'           s =  showString "\\r" s+showLitChar '\t'           s =  showString "\\t" s+showLitChar '\v'           s =  showString "\\v" s+showLitChar '\SO'          s =  protectEsc (== 'H') (showString "\\SO") s+showLitChar c              s =  showString ('\\' : asciiTab!!ord c) s+        -- I've done manual eta-expansion here, becuase otherwise it's+        -- impossible to stop (asciiTab!!ord) getting floated out as an MFE++isDec :: Char -> Bool+isDec c = c >= '0' && c <= '9'++protectEsc :: (Char -> Bool) -> ShowS -> ShowS+protectEsc p f             = f . cont+                             where cont s@(c:_) | p c = "\\&" ++ s+                                   cont s             = s+++asciiTab :: [String]+asciiTab = -- Using an array drags in the array module.  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"] +\end{code}++Code specific for Ints.++\begin{code}+-- | Convert an 'Int' in the range @0@..@15@ to the corresponding single+-- digit 'Char'.  This function fails on other inputs, and generates+-- lower-case hexadecimal digits.+intToDigit :: Int -> Char+intToDigit (I# i)+    | i >=# 0#  && i <=#  9# =  unsafeChr (ord '0' `plusInt` I# i)+    | i >=# 10# && i <=# 15# =  unsafeChr (ord 'a' `minusInt` ten `plusInt` I# i)+    | otherwise           =  error ("Char.intToDigit: not a digit " ++ show (I# i))++ten :: Int+ten = I# 10#++showSignedInt :: Int -> Int -> ShowS+showSignedInt (I# p) (I# n) r+    | n <# 0# && p ># 6# = '(' : itos n (')' : r)+    | otherwise          = itos n r++itos :: Int# -> String -> String+itos n# cs+    | n# <# 0# =+        let I# minInt# = minInt in+        if n# ==# minInt#+                -- negateInt# minInt overflows, so we can't do that:+           then '-' : itos' (negateInt# (n# `quotInt#` 10#))+                             (itos' (negateInt# (n# `remInt#` 10#)) cs)+           else '-' : itos' (negateInt# n#) cs+    | otherwise = itos' n# cs+    where+    itos' :: Int# -> String -> String+    itos' x# cs'+        | x# <# 10#  = C# (chr# (ord# '0'# +# x#)) : cs'+        | otherwise = case chr# (ord# '0'# +# (x# `remInt#` 10#)) of { c# ->+                      itos' (x# `quotInt#` 10#) (C# c# : cs') }+\end{code}
+ lib/base/src/GHC/Stable.lhs view
@@ -0,0 +1,107 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Stable+-- Copyright   :  (c) The University of Glasgow, 1992-2004+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Stable pointers.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Stable +        ( StablePtr(..)+        , newStablePtr          -- :: a -> IO (StablePtr a)    +        , deRefStablePtr        -- :: StablePtr a -> a+        , freeStablePtr         -- :: StablePtr a -> IO ()+        , castStablePtrToPtr    -- :: StablePtr a -> Ptr ()+        , castPtrToStablePtr    -- :: Ptr () -> StablePtr a+   ) where++import GHC.Ptr+import GHC.Base+import GHC.IOBase++-----------------------------------------------------------------------------+-- Stable Pointers++{- |+A /stable pointer/ is a reference to a Haskell expression that is+guaranteed not to be affected by garbage collection, i.e., it will neither be+deallocated nor will the value of the stable pointer itself change during+garbage collection (ordinary references may be relocated during garbage+collection).  Consequently, stable pointers can be passed to foreign code,+which can treat it as an opaque reference to a Haskell value.++A value of type @StablePtr a@ is a stable pointer to a Haskell+expression of type @a@.+-}+data StablePtr a = StablePtr (StablePtr# a)++-- |+-- Create a stable pointer referring to the given Haskell value.+--+newStablePtr   :: a -> IO (StablePtr a)+newStablePtr a = IO $ \ s ->+    case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #)++-- |+-- Obtain the Haskell value referenced by a stable pointer, i.e., the+-- same value that was passed to the corresponding call to+-- 'makeStablePtr'.  If the argument to 'deRefStablePtr' has+-- already been freed using 'freeStablePtr', the behaviour of+-- 'deRefStablePtr' is undefined.+--+deRefStablePtr :: StablePtr a -> IO a+deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s++-- |+-- Dissolve the association between the stable pointer and the Haskell+-- value. Afterwards, if the stable pointer is passed to+-- 'deRefStablePtr' or 'freeStablePtr', the behaviour is+-- undefined.  However, the stable pointer may still be passed to+-- 'castStablePtrToPtr', but the @'Foreign.Ptr.Ptr' ()@ value returned+-- by 'castStablePtrToPtr', in this case, is undefined (in particular,+-- it may be 'Foreign.Ptr.nullPtr').  Nevertheless, the call+-- to 'castStablePtrToPtr' is guaranteed not to diverge.+--+foreign import ccall unsafe "hs_free_stable_ptr" freeStablePtr :: StablePtr a -> IO ()++-- |+-- Coerce a stable pointer to an address. No guarantees are made about+-- the resulting value, except that the original stable pointer can be+-- recovered by 'castPtrToStablePtr'.  In particular, the address may not+-- refer to an accessible memory location and any attempt to pass it to+-- the member functions of the class 'Foreign.Storable.Storable' leads to+-- undefined behaviour.+--+castStablePtrToPtr :: StablePtr a -> Ptr ()+castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerce# s)+++-- |+-- The inverse of 'castStablePtrToPtr', i.e., we have the identity+-- +-- > sp == castPtrToStablePtr (castStablePtrToPtr sp)+-- +-- for any stable pointer @sp@ on which 'freeStablePtr' has+-- not been executed yet.  Moreover, 'castPtrToStablePtr' may+-- only be applied to pointers that have been produced by+-- 'castStablePtrToPtr'.+--+castPtrToStablePtr :: Ptr () -> StablePtr a+castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerce# a)++instance Eq (StablePtr a) where +    (StablePtr sp1) == (StablePtr sp2) =+        case eqStablePtr# sp1 sp2 of+           0# -> False+           _  -> True+\end{code}
+ lib/base/src/GHC/Storable.lhs view
@@ -0,0 +1,164 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Storable+-- Copyright   :  (c) The FFI task force, 2000-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Helper functions for "Foreign.Storable"+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Storable+        ( readWideCharOffPtr  +        , readIntOffPtr       +        , readWordOffPtr      +        , readPtrOffPtr       +        , readFunPtrOffPtr    +        , readFloatOffPtr     +        , readDoubleOffPtr    +        , readStablePtrOffPtr +        , readInt8OffPtr      +        , readInt16OffPtr     +        , readInt32OffPtr     +        , readInt64OffPtr     +        , readWord8OffPtr     +        , readWord16OffPtr    +        , readWord32OffPtr    +        , readWord64OffPtr    +        , writeWideCharOffPtr +        , writeIntOffPtr      +        , writeWordOffPtr     +        , writePtrOffPtr      +        , writeFunPtrOffPtr   +        , writeFloatOffPtr    +        , writeDoubleOffPtr   +        , writeStablePtrOffPtr+        , writeInt8OffPtr     +        , writeInt16OffPtr    +        , writeInt32OffPtr    +        , writeInt64OffPtr    +        , writeWord8OffPtr    +        , writeWord16OffPtr   +        , writeWord32OffPtr   +        , writeWord64OffPtr   +        ) where++import GHC.Stable       ( StablePtr(..) )+import GHC.Int+import GHC.Word+import GHC.Ptr+import GHC.IOBase+import GHC.Base+\end{code}++\begin{code}++readWideCharOffPtr  :: Ptr Char          -> Int -> IO Char+readIntOffPtr       :: Ptr Int           -> Int -> IO Int+readWordOffPtr      :: Ptr Word          -> Int -> IO Word+readPtrOffPtr       :: Ptr (Ptr a)       -> Int -> IO (Ptr a)+readFunPtrOffPtr    :: Ptr (FunPtr a)    -> Int -> IO (FunPtr a)+readFloatOffPtr     :: Ptr Float         -> Int -> IO Float+readDoubleOffPtr    :: Ptr Double        -> Int -> IO Double+readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)+readInt8OffPtr      :: Ptr Int8          -> Int -> IO Int8+readInt16OffPtr     :: Ptr Int16         -> Int -> IO Int16+readInt32OffPtr     :: Ptr Int32         -> Int -> IO Int32+readInt64OffPtr     :: Ptr Int64         -> Int -> IO Int64+readWord8OffPtr     :: Ptr Word8         -> Int -> IO Word8+readWord16OffPtr    :: Ptr Word16        -> Int -> IO Word16+readWord32OffPtr    :: Ptr Word32        -> Int -> IO Word32+readWord64OffPtr    :: Ptr Word64        -> Int -> IO Word64++readWideCharOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readWideCharOffAddr# a i s  of (# s2, x #) -> (# s2, C# x #)+readIntOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readIntOffAddr# a i s       of (# s2, x #) -> (# s2, I# x #)+readWordOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readWordOffAddr# a i s      of (# s2, x #) -> (# s2, W# x #)+readPtrOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, Ptr x #)+readFunPtrOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, FunPtr x #)+readFloatOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readFloatOffAddr# a i s     of (# s2, x #) -> (# s2, F# x #)+readDoubleOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readDoubleOffAddr# a i s    of (# s2, x #) -> (# s2, D# x #)+readStablePtrOffPtr (Ptr a) (I# i)+  = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #)+readInt8OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readInt8OffAddr# a i s      of (# s2, x #) -> (# s2, I8# x #)+readWord8OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readWord8OffAddr# a i s     of (# s2, x #) -> (# s2, W8# x #)+readInt16OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readInt16OffAddr# a i s     of (# s2, x #) -> (# s2, I16# x #)+readWord16OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readWord16OffAddr# a i s    of (# s2, x #) -> (# s2, W16# x #)+readInt32OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readInt32OffAddr# a i s     of (# s2, x #) -> (# s2, I32# x #)+readWord32OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readWord32OffAddr# a i s    of (# s2, x #) -> (# s2, W32# x #)+readInt64OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readInt64OffAddr# a i s     of (# s2, x #) -> (# s2, I64# x #)+readWord64OffPtr (Ptr a) (I# i)+  = IO $ \s -> case readWord64OffAddr# a i s    of (# s2, x #) -> (# s2, W64# x #)++writeWideCharOffPtr  :: Ptr Char          -> Int -> Char        -> IO ()+writeIntOffPtr       :: Ptr Int           -> Int -> Int         -> IO ()+writeWordOffPtr      :: Ptr Word          -> Int -> Word        -> IO ()+writePtrOffPtr       :: Ptr (Ptr a)       -> Int -> Ptr a       -> IO ()+writeFunPtrOffPtr    :: Ptr (FunPtr a)    -> Int -> FunPtr a    -> IO ()+writeFloatOffPtr     :: Ptr Float         -> Int -> Float       -> IO ()+writeDoubleOffPtr    :: Ptr Double        -> Int -> Double      -> IO ()+writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO ()+writeInt8OffPtr      :: Ptr Int8          -> Int -> Int8        -> IO ()+writeInt16OffPtr     :: Ptr Int16         -> Int -> Int16       -> IO ()+writeInt32OffPtr     :: Ptr Int32         -> Int -> Int32       -> IO ()+writeInt64OffPtr     :: Ptr Int64         -> Int -> Int64       -> IO ()+writeWord8OffPtr     :: Ptr Word8         -> Int -> Word8       -> IO ()+writeWord16OffPtr    :: Ptr Word16        -> Int -> Word16      -> IO ()+writeWord32OffPtr    :: Ptr Word32        -> Int -> Word32      -> IO ()+writeWord64OffPtr    :: Ptr Word64        -> Int -> Word64      -> IO ()++writeWideCharOffPtr (Ptr a) (I# i) (C# x)+  = IO $ \s -> case writeWideCharOffAddr# a i x s  of s2 -> (# s2, () #)+writeIntOffPtr (Ptr a) (I# i) (I# x)+  = IO $ \s -> case writeIntOffAddr# a i x s       of s2 -> (# s2, () #)+writeWordOffPtr (Ptr a) (I# i) (W# x)+  = IO $ \s -> case writeWordOffAddr# a i x s      of s2 -> (# s2, () #)+writePtrOffPtr (Ptr a) (I# i) (Ptr x)+  = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)+writeFunPtrOffPtr (Ptr a) (I# i) (FunPtr x)+  = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)+writeFloatOffPtr (Ptr a) (I# i) (F# x)+  = IO $ \s -> case writeFloatOffAddr# a i x s     of s2 -> (# s2, () #)+writeDoubleOffPtr (Ptr a) (I# i) (D# x)+  = IO $ \s -> case writeDoubleOffAddr# a i x s    of s2 -> (# s2, () #)+writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x)+  = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #)+writeInt8OffPtr (Ptr a) (I# i) (I8# x)+  = IO $ \s -> case writeInt8OffAddr# a i x s      of s2 -> (# s2, () #)+writeWord8OffPtr (Ptr a) (I# i) (W8# x)+  = IO $ \s -> case writeWord8OffAddr# a i x s     of s2 -> (# s2, () #)+writeInt16OffPtr (Ptr a) (I# i) (I16# x)+  = IO $ \s -> case writeInt16OffAddr# a i x s     of s2 -> (# s2, () #)+writeWord16OffPtr (Ptr a) (I# i) (W16# x)+  = IO $ \s -> case writeWord16OffAddr# a i x s    of s2 -> (# s2, () #)+writeInt32OffPtr (Ptr a) (I# i) (I32# x)+  = IO $ \s -> case writeInt32OffAddr# a i x s     of s2 -> (# s2, () #)+writeWord32OffPtr (Ptr a) (I# i) (W32# x)+  = IO $ \s -> case writeWord32OffAddr# a i x s    of s2 -> (# s2, () #)+writeInt64OffPtr (Ptr a) (I# i) (I64# x)+  = IO $ \s -> case writeInt64OffAddr# a i x s     of s2 -> (# s2, () #)+writeWord64OffPtr (Ptr a) (I# i) (W64# x)+  = IO $ \s -> case writeWord64OffAddr# a i x s    of s2 -> (# s2, () #)++\end{code}
+ lib/base/src/GHC/TopHandler.lhs view
@@ -0,0 +1,203 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.TopHandler+-- Copyright   :  (c) The University of Glasgow, 2001-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Support for catching exceptions raised during top-level computations+-- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)+--+-----------------------------------------------------------------------------++-- #hide+module GHC.TopHandler (+   runMainIO, runIO, runIOFastExit, runNonIO,+   topHandler, topHandlerFastExit,+   reportStackOverflow, reportError,+  ) where++import Control.Exception+import Data.Maybe+import Data.Dynamic (toDyn)++import Foreign+import Foreign.C+import GHC.Base+import GHC.Conc hiding (throwTo)+import GHC.Num+import GHC.Real+import GHC.Handle+import GHC.IOBase+--import GHC.Weak+import Data.Typeable+#if defined(mingw32_HOST_OS)+import GHC.ConsoleHandler+#endif++-- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is+-- called in the program).  It catches otherwise uncaught exceptions,+-- and also flushes stdout\/stderr before exiting.+runMainIO :: IO a -> IO a+runMainIO main = +    do +      {-main_thread_id <- myThreadId+      weak_tid <- mkWeakThreadId main_thread_id+      install_interrupt_handler $ do+           m <- deRefWeak weak_tid +           case m of+               Nothing  -> return ()+               Just tid -> throwTo tid (toException UserInterrupt)-}+      a <- main+      cleanUp+      return a+    `catch`+      topHandler++install_interrupt_handler :: IO () -> IO ()+#ifdef mingw32_HOST_OS+install_interrupt_handler handler = do+  GHC.ConsoleHandler.installHandler $+     Catch $ \event -> +        case event of+           ControlC -> handler+           Break    -> handler+           Close    -> handler+           _ -> return ()+  return ()+#else+-- #include "Signals.h"+-- specialised version of System.Posix.Signals.installHandler, which+-- isn't available here.+install_interrupt_handler handler = do+   --let sig = CONST_SIGINT :: CInt+   --setHandler sig (Just (const handler, toDyn handler))+   --stg_sig_install sig STG_SIG_RST nullPtr+     -- STG_SIG_RST: the second ^C kills us for real, just in case the+     -- RTS or program is unresponsive.+   return ()++foreign import ccall unsafe+  stg_sig_install+	:: CInt				-- sig no.+	-> CInt				-- action code (STG_SIG_HAN etc.)+	-> Ptr ()			-- (in, out) blocked+	-> IO CInt			-- (ret) old action code+#endif++-- make a weak pointer to a ThreadId: holding the weak pointer doesn't+-- keep the thread alive and prevent it from being identified as+-- deadlocked.  Vitally important for the main thread.+{-+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->+   case mkWeak# t# t (unsafeCoerce# 0#) s of +      (# s1, w #) -> (# s1, Weak w #)+-}+-- | 'runIO' is wrapped around every @foreign export@ and @foreign+-- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the+-- result of running 'System.Exit.exitWith' in a foreign-exported+-- function is the same as in the main thread: it terminates the+-- program.+--+runIO :: IO a -> IO a+runIO main = catch main topHandler++-- | Like 'runIO', but in the event of an exception that causes an exit,+-- we don't shut down the system cleanly, we just exit.  This is+-- useful in some cases, because the safe exit version will give other+-- threads a chance to clean up first, which might shut down the+-- system in a different way.  For example, try +--+--   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000+--+-- This will sometimes exit with "interrupted" and code 0, because the+-- main thread is given a chance to shut down when the child thread calls+-- safeExit.  There is a race to shut down between the main and child threads.+--+runIOFastExit :: IO a -> IO a+runIOFastExit main = catch main topHandlerFastExit+        -- NB. this is used by the testsuite driver++-- | The same as 'runIO', but for non-IO computations.  Used for+-- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these+-- are used to export Haskell functions with non-IO types.+--+runNonIO :: a -> IO a+runNonIO a = catch (a `seq` return a) topHandler++topHandler :: SomeException -> IO a+topHandler err = catch (real_handler safeExit err) topHandler++topHandlerFastExit :: SomeException -> IO a+topHandlerFastExit err = +  catchException (real_handler fastExit err) topHandlerFastExit++-- Make sure we handle errors while reporting the error!+-- (e.g. evaluating the string passed to 'error' might generate+--  another error, etc.)+--+real_handler :: (Int -> IO a) -> SomeException -> IO a+real_handler exit se@(SomeException exn) =+  cleanUp >>+  case cast exn of+      Just StackOverflow -> do+           reportStackOverflow+           exit 2++      Just UserInterrupt  -> exitInterrupted++      _ -> case cast exn of+           -- only the main thread gets ExitException exceptions+           Just ExitSuccess     -> exit 0+           Just (ExitFailure n) -> exit n++           _ -> do reportError se+                   exit 1+           ++-- try to flush stdout/stderr, but don't worry if we fail+-- (these handles might have errors, and we don't want to go into+-- an infinite loop).+cleanUp :: IO ()+cleanUp = do+  hFlush stdout `catchAny` \_ -> return ()+  hFlush stderr `catchAny` \_ -> return ()++-- we have to use unsafeCoerce# to get the 'IO a' result type, since the+-- compiler doesn't let us declare that as the result type of a foreign export.+safeExit :: Int -> IO a+safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)++exitInterrupted :: IO a+exitInterrupted = +#ifdef mingw32_HOST_OS+  safeExit 252+#else+  -- we must exit via the default action for SIGINT, so that the+  -- parent of this process can take appropriate action (see #2301)+  --unsafeCoerce# (shutdownHaskellAndSignal CONST_SIGINT)+  error "exitInterrupted"++foreign import ccall "shutdownHaskellAndSignal"+  shutdownHaskellAndSignal :: CInt -> IO ()+#endif++-- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*+-- re-enter Haskell land through finalizers.+foreign import ccall "Rts.h shutdownHaskellAndExit"+  shutdownHaskellAndExit :: CInt -> IO ()++fastExit :: Int -> IO a+fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))++foreign import ccall "Rts.h stg_exit"+  stg_exit :: CInt -> IO ()+\end{code}
+ lib/base/src/GHC/Unicode.hs view
@@ -0,0 +1,223 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS -#include "WCsubst.h" #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Unicode+-- Copyright   :  (c) The University of Glasgow, 2003+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Implementations for the character predicates (isLower, isUpper, etc.)+-- and the conversions (toUpper, toLower).  The implementation uses+-- libunicode on Unix systems if that is available.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Unicode (+    isAscii, isLatin1, isControl,+    isAsciiUpper, isAsciiLower,+    isPrint, isSpace,  isUpper,+    isLower, isAlpha,  isDigit,+    isOctDigit, isHexDigit, isAlphaNum,+    toUpper, toLower, toTitle,+  ) where++import GHC.Base+import GHC.Real        (fromIntegral)+import Foreign.C.Types (CInt)+import GHC.Num         (fromInteger)+++-- | Selects the first 128 characters of the Unicode character set,+-- corresponding to the ASCII character set.+isAscii                 :: Char -> Bool+isAscii c               =  c <  '\x80'++-- | Selects the first 256 characters of the Unicode character set,+-- corresponding to the ISO 8859-1 (Latin-1) character set.+isLatin1                :: Char -> Bool+isLatin1 c              =  c <= '\xff'++-- | Selects ASCII lower-case letters,+-- i.e. characters satisfying both 'isAscii' and 'isLower'.+isAsciiLower :: Char -> Bool+isAsciiLower c          =  c >= 'a' && c <= 'z'++-- | Selects ASCII upper-case letters,+-- i.e. characters satisfying both 'isAscii' and 'isUpper'.+isAsciiUpper :: Char -> Bool+isAsciiUpper c          =  c >= 'A' && c <= 'Z'++-- | Selects control characters, which are the non-printing characters of+-- the Latin-1 subset of Unicode.+isControl               :: Char -> Bool++-- | Selects printable Unicode characters+-- (letters, numbers, marks, punctuation, symbols and spaces).+isPrint                 :: Char -> Bool++-- | Selects white-space characters in the Latin-1 range.+-- (In Unicode terms, this includes spaces and some control characters.)+isSpace                 :: Char -> Bool+-- isSpace includes non-breaking space+-- Done with explicit equalities both for efficiency, and to avoid a tiresome+-- recursion with GHC.List elem+isSpace c               =  c == ' '     ||+                           c == '\t'    ||+                           c == '\n'    ||+                           c == '\r'    ||+                           c == '\f'    ||+                           c == '\v'    ||+                           c == '\xa0'  ||+                           False -- iswspace (fromIntegral (ord c)) /= 0++-- | Selects upper-case or title-case alphabetic Unicode characters (letters).+-- Title case is used by a small number of letter ligatures like the+-- single-character form of /Lj/.+isUpper                 :: Char -> Bool++-- | Selects lower-case alphabetic Unicode characters (letters).+isLower                 :: Char -> Bool++-- | Selects alphabetic Unicode characters (lower-case, upper-case and+-- title-case letters, plus letters of caseless scripts and modifiers letters).+-- This function is equivalent to 'Data.Char.isLetter'.+isAlpha                 :: Char -> Bool++-- | Selects alphabetic or numeric digit Unicode characters.+--+-- Note that numeric digits outside the ASCII range are selected by this+-- function but not by 'isDigit'.  Such digits may be part of identifiers+-- but are not used by the printer and reader to represent numbers.+isAlphaNum              :: Char -> Bool++-- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@.+isDigit                 :: Char -> Bool+isDigit c               =  c >= '0' && c <= '9'++-- | Selects ASCII octal digits, i.e. @\'0\'@..@\'7\'@.+isOctDigit              :: Char -> Bool+isOctDigit c            =  c >= '0' && c <= '7'++-- | Selects ASCII hexadecimal digits,+-- i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@.+isHexDigit              :: Char -> Bool+isHexDigit c            =  isDigit c || c >= 'A' && c <= 'F' ||+                                        c >= 'a' && c <= 'f'++-- | Convert a letter to the corresponding upper-case letter, if any.+-- Any other character is returned unchanged.+toUpper                 :: Char -> Char++-- | Convert a letter to the corresponding lower-case letter, if any.+-- Any other character is returned unchanged.+toLower                 :: Char -> Char++-- | Convert a letter to the corresponding title-case or upper-case+-- letter, if any.  (Title case differs from upper case only for a small+-- number of ligature letters.)+-- Any other character is returned unchanged.+toTitle                 :: Char -> Char++-- -----------------------------------------------------------------------------+-- Implementation with the supplied auto-generated Unicode character properties+-- table (default)++#if 0++-- Regardless of the O/S and Library, use the functions contained in WCsubst.c++isAlpha    c = iswalpha (fromIntegral (ord c)) /= 0+isAlphaNum c = iswalnum (fromIntegral (ord c)) /= 0+--isSpace    c = iswspace (fromIntegral (ord c)) /= 0+isControl  c = iswcntrl (fromIntegral (ord c)) /= 0+isPrint    c = iswprint (fromIntegral (ord c)) /= 0+isUpper    c = iswupper (fromIntegral (ord c)) /= 0+isLower    c = iswlower (fromIntegral (ord c)) /= 0++toLower c = chr (fromIntegral (towlower (fromIntegral (ord c))))+toUpper c = chr (fromIntegral (towupper (fromIntegral (ord c))))+toTitle c = chr (fromIntegral (towtitle (fromIntegral (ord c))))++foreign import ccall unsafe "u_iswalpha"+  iswalpha :: CInt -> CInt++foreign import ccall unsafe "u_iswalnum"+  iswalnum :: CInt -> CInt++foreign import ccall unsafe "u_iswcntrl"+  iswcntrl :: CInt -> CInt++foreign import ccall unsafe "u_iswspace"+  iswspace :: CInt -> CInt++foreign import ccall unsafe "u_iswprint"+  iswprint :: CInt -> CInt++foreign import ccall unsafe "u_iswlower"+  iswlower :: CInt -> CInt++foreign import ccall unsafe "u_iswupper"+  iswupper :: CInt -> CInt++foreign import ccall unsafe "u_towlower"+  towlower :: CInt -> CInt++foreign import ccall unsafe "u_towupper"+  towupper :: CInt -> CInt++foreign import ccall unsafe "u_towtitle"+  towtitle :: CInt -> CInt++foreign import ccall unsafe "u_gencat"+  wgencat :: CInt -> CInt++-- -----------------------------------------------------------------------------+-- No libunicode, so fall back to the ASCII-only implementation (never used, indeed)++#else++isControl c             =  c < ' ' || c >= '\DEL' && c <= '\x9f'+isPrint c               =  not (isControl c)++-- The upper case ISO characters have the multiplication sign dumped+-- randomly in the middle of the range.  Go figure.+isUpper c               =  c >= 'A' && c <= 'Z' ||+                           c >= '\xC0' && c <= '\xD6' ||+                           c >= '\xD8' && c <= '\xDE'+-- The lower case ISO characters have the division sign dumped+-- randomly in the middle of the range.  Go figure.+isLower c               =  c >= 'a' && c <= 'z' ||+                           c >= '\xDF' && c <= '\xF6' ||+                           c >= '\xF8' && c <= '\xFF'++isAlpha c               =  isLower c || isUpper c+isAlphaNum c            =  isAlpha c || isDigit c++-- Case-changing operations++toUpper c@(C# c#)+  | isAsciiLower c    = C# (chr# (ord# c# -# 32#))+  | isAscii c         = c+    -- fall-through to the slower stuff.+  | isLower c   && c /= '\xDF' && c /= '\xFF'+  = unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A')+  | otherwise+  = c+++toLower c@(C# c#)+  | isAsciiUpper c = C# (chr# (ord# c# +# 32#))+  | isAscii c      = c+  | isUpper c      = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')+  | otherwise      =  c++toTitle c = c++#endif+
+ lib/base/src/GHC/Unicode.hs-boot view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Unicode where++import GHC.Bool+import GHC.Types++isAscii         :: Char -> Bool+isLatin1        :: Char -> Bool+isControl       :: Char -> Bool+isPrint         :: Char -> Bool+isSpace         :: Char -> Bool+isUpper         :: Char -> Bool+isLower         :: Char -> Bool+isAlpha         :: Char -> Bool+isDigit         :: Char -> Bool+isOctDigit      :: Char -> Bool+isHexDigit      :: Char -> Bool+isAlphaNum      :: Char -> Bool
+ lib/base/src/GHC/Word.hs view
@@ -0,0 +1,874 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Word+-- Copyright   :  (c) The University of Glasgow, 1997-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Sized unsigned integral types: 'Word', 'Word8', 'Word16', 'Word32', and+-- 'Word64'.+--+-----------------------------------------------------------------------------++#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#)+#define WORD_SIZE_IN_BITS (WORD_SIZE * 8)+++-- #hide+module GHC.Word (+    Word(..), Word8(..), Word16(..), Word32(..), Word64(..),+    toEnumError, fromEnumError, succError, predError,+    uncheckedShiftL64#,+    uncheckedShiftRL64#+    ) where++import Data.Bits++#if WORD_SIZE < 4+import GHC.IntWord32+#endif+#if WORD_SIZE < 8+import GHC.IntWord64+#endif++import GHC.Base+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Read+import GHC.Arr+import GHC.Show++------------------------------------------------------------------------+-- Helper functions+------------------------------------------------------------------------++{-# NOINLINE toEnumError #-}+toEnumError :: (Show a) => String -> Int -> (a,a) -> b+toEnumError inst_ty i bnds =+    error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" +++            show i +++            ") is outside of bounds " +++            show bnds++{-# NOINLINE fromEnumError #-}+fromEnumError :: (Show a) => String -> a -> b+fromEnumError inst_ty x =+    error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" +++            show x +++            ") is outside of Int's bounds " +++            show (minBound::Int, maxBound::Int)++{-# NOINLINE succError #-}+succError :: String -> a+succError inst_ty =+    error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"++{-# NOINLINE predError #-}+predError :: String -> a+predError inst_ty =+    error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"++------------------------------------------------------------------------+-- type Word+------------------------------------------------------------------------++-- |A 'Word' is an unsigned integral type, with the same size as 'Int'.+data Word = W# Word# deriving (Eq, Ord)++instance Show Word where+    showsPrec p x = showsPrec p (toInteger x)++instance Num Word where+    (W# x#) + (W# y#)      = W# (x# `plusWord#` y#)+    (W# x#) - (W# y#)      = W# (x# `minusWord#` y#)+    (W# x#) * (W# y#)      = W# (x# `timesWord#` y#)+    negate (W# x#)         = W# (int2Word# (negateInt# (word2Int# x#)))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W# (integerToWord i)++instance Real Word where+    toRational x = toInteger x % 1++instance Enum Word where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word"+    toEnum i@(I# i#)+        | i >= 0        = W# (int2Word# i#)+        | otherwise     = toEnumError "Word" i (minBound::Word, maxBound::Word)+    fromEnum x@(W# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# x#)+        | otherwise     = fromEnumError "Word" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Word where+    quot    (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `quotWord#` y#)+        | otherwise             = divZeroError+    rem     (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `remWord#` y#)+        | otherwise             = divZeroError+    div     (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `quotWord#` y#)+        | otherwise             = divZeroError+    mod     (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `remWord#` y#)+        | otherwise             = divZeroError+    quotRem (W# x#) y@(W# y#)+        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))+        | otherwise             = divZeroError+    divMod  (W# x#) y@(W# y#)+        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))+        | otherwise             = divZeroError+    toInteger (W# x#)+        | i# >=# 0#             = smallInteger i#+        | otherwise             = wordToInteger x#+        where+        i# = word2Int# x#++instance Bounded Word where+    minBound = 0++    -- use unboxed literals for maxBound, because GHC doesn't optimise+    -- (fromInteger 0xffffffff :: Word).+#if WORD_SIZE_IN_BITS == 31+    maxBound = W# (int2Word# 0x7FFFFFFF#)+#elif WORD_SIZE_IN_BITS == 32+    maxBound = W# (int2Word# 0xFFFFFFFF#)+#else+    maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#)+#endif++instance Ix Word where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]++instance Bits Word where+    {-# INLINE shift #-}++    (W# x#) .&.   (W# y#)    = W# (x# `and#` y#)+    (W# x#) .|.   (W# y#)    = W# (x# `or#`  y#)+    (W# x#) `xor` (W# y#)    = W# (x# `xor#` y#)+    complement (W# x#)       = W# (x# `xor#` mb#) where W# mb# = maxBound+    (W# x#) `shift` (I# i#)+        | i# >=# 0#          = W# (x# `shiftL#` i#)+        | otherwise          = W# (x# `shiftRL#` negateInt# i#)+    (W# x#) `rotate` (I# i#)+        | i'# ==# 0# = W# x#+        | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        wsib = WORD_SIZE_IN_BITS_  {- work around preprocessor problem (??) -}+    bitSize  _               = WORD_SIZE_IN_BITS+    isSigned _               = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int->Word"  fromIntegral = \(I# x#) -> W# (int2Word# x#)+"fromIntegral/Word->Int"  fromIntegral = \(W# x#) -> I# (word2Int# x#)+"fromIntegral/Word->Word" fromIntegral = id :: Word -> Word+  #-}++------------------------------------------------------------------------+-- type Word8+------------------------------------------------------------------------++-- Word8 is represented in the same way as Word. Operations may assume+-- and must ensure that it holds only values from its logical range.++data Word8 = W8# Word# deriving (Eq, Ord)+-- ^ 8-bit unsigned integer type++instance Show Word8 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Word8 where+    (W8# x#) + (W8# y#)    = W8# (narrow8Word# (x# `plusWord#` y#))+    (W8# x#) - (W8# y#)    = W8# (narrow8Word# (x# `minusWord#` y#))+    (W8# x#) * (W8# y#)    = W8# (narrow8Word# (x# `timesWord#` y#))+    negate (W8# x#)        = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#))))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W8# (narrow8Word# (integerToWord i))++instance Real Word8 where+    toRational x = toInteger x % 1++instance Enum Word8 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word8"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word8"+    toEnum i@(I# i#)+        | i >= 0 && i <= fromIntegral (maxBound::Word8)+                        = W8# (int2Word# i#)+        | otherwise     = toEnumError "Word8" i (minBound::Word8, maxBound::Word8)+    fromEnum (W8# x#)   = I# (word2Int# x#)+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Word8 where+    quot    (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `quotWord#` y#)+        | otherwise               = divZeroError+    rem     (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `remWord#` y#)+        | otherwise               = divZeroError+    div     (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `quotWord#` y#)+        | otherwise               = divZeroError+    mod     (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `remWord#` y#)+        | otherwise               = divZeroError+    quotRem (W8# x#) y@(W8# y#)+        | y /= 0                  = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))+        | otherwise               = divZeroError+    divMod  (W8# x#) y@(W8# y#)+        | y /= 0                  = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))+        | otherwise               = divZeroError+    toInteger (W8# x#)            = smallInteger (word2Int# x#)++instance Bounded Word8 where+    minBound = 0+    maxBound = 0xFF++instance Ix Word8 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word8 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Word8 where+    {-# INLINE shift #-}++    (W8# x#) .&.   (W8# y#)   = W8# (x# `and#` y#)+    (W8# x#) .|.   (W8# y#)   = W8# (x# `or#`  y#)+    (W8# x#) `xor` (W8# y#)   = W8# (x# `xor#` y#)+    complement (W8# x#)       = W8# (x# `xor#` mb#) where W8# mb# = maxBound+    (W8# x#) `shift` (I# i#)+        | i# >=# 0#           = W8# (narrow8Word# (x# `shiftL#` i#))+        | otherwise           = W8# (x# `shiftRL#` negateInt# i#)+    (W8# x#) `rotate` (I# i#)+        | i'# ==# 0# = W8# x#+        | otherwise  = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                          (x# `uncheckedShiftRL#` (8# -# i'#))))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)+    bitSize  _                = 8+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Word8"   fromIntegral = id :: Word8 -> Word8+"fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer+"fromIntegral/a->Word8"       fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#)+"fromIntegral/Word8->a"       fromIntegral = \(W8# x#) -> fromIntegral (W# x#)+  #-}++------------------------------------------------------------------------+-- type Word16+------------------------------------------------------------------------++-- Word16 is represented in the same way as Word. Operations may assume+-- and must ensure that it holds only values from its logical range.++data Word16 = W16# Word# deriving (Eq, Ord)+-- ^ 16-bit unsigned integer type++instance Show Word16 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Word16 where+    (W16# x#) + (W16# y#)  = W16# (narrow16Word# (x# `plusWord#` y#))+    (W16# x#) - (W16# y#)  = W16# (narrow16Word# (x# `minusWord#` y#))+    (W16# x#) * (W16# y#)  = W16# (narrow16Word# (x# `timesWord#` y#))+    negate (W16# x#)       = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#))))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W16# (narrow16Word# (integerToWord i))++instance Real Word16 where+    toRational x = toInteger x % 1++instance Enum Word16 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word16"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word16"+    toEnum i@(I# i#)+        | i >= 0 && i <= fromIntegral (maxBound::Word16)+                        = W16# (int2Word# i#)+        | otherwise     = toEnumError "Word16" i (minBound::Word16, maxBound::Word16)+    fromEnum (W16# x#)  = I# (word2Int# x#)+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Word16 where+    quot    (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    rem     (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    div     (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    mod     (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    quotRem (W16# x#) y@(W16# y#)+        | y /= 0                    = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    divMod  (W16# x#) y@(W16# y#)+        | y /= 0                    = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    toInteger (W16# x#)             = smallInteger (word2Int# x#)++instance Bounded Word16 where+    minBound = 0+    maxBound = 0xFFFF++instance Ix Word16 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word16 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Word16 where+    {-# INLINE shift #-}++    (W16# x#) .&.   (W16# y#)  = W16# (x# `and#` y#)+    (W16# x#) .|.   (W16# y#)  = W16# (x# `or#`  y#)+    (W16# x#) `xor` (W16# y#)  = W16# (x# `xor#` y#)+    complement (W16# x#)       = W16# (x# `xor#` mb#) where W16# mb# = maxBound+    (W16# x#) `shift` (I# i#)+        | i# >=# 0#            = W16# (narrow16Word# (x# `shiftL#` i#))+        | otherwise            = W16# (x# `shiftRL#` negateInt# i#)+    (W16# x#) `rotate` (I# i#)+        | i'# ==# 0# = W16# x#+        | otherwise  = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (16# -# i'#))))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)+    bitSize  _                = 16+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Word16"   fromIntegral = \(W8# x#) -> W16# x#+"fromIntegral/Word16->Word16"  fromIntegral = id :: Word16 -> Word16+"fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer+"fromIntegral/a->Word16"       fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#)+"fromIntegral/Word16->a"       fromIntegral = \(W16# x#) -> fromIntegral (W# x#)+  #-}++------------------------------------------------------------------------+-- type Word32+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 32++data Word32 = W32# Word32#+-- ^ 32-bit unsigned integer type++instance Eq Word32 where+    (W32# x#) == (W32# y#) = x# `eqWord32#` y#+    (W32# x#) /= (W32# y#) = x# `neWord32#` y#++instance Ord Word32 where+    (W32# x#) <  (W32# y#) = x# `ltWord32#` y#+    (W32# x#) <= (W32# y#) = x# `leWord32#` y#+    (W32# x#) >  (W32# y#) = x# `gtWord32#` y#+    (W32# x#) >= (W32# y#) = x# `geWord32#` y#++instance Num Word32 where+    (W32# x#) + (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#))+    (W32# x#) - (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#))+    (W32# x#) * (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#))+    negate (W32# x#)       = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#)))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger (S# i#)    = W32# (int32ToWord32# (intToInt32# i#))+    fromInteger (J# s# d#) = W32# (integerToWord32# s# d#)++instance Enum Word32 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word32"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word32"+    toEnum i@(I# i#)+        | i >= 0        = W32# (wordToWord32# (int2Word# i#))+        | otherwise     = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)+    fromEnum x@(W32# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# (word32ToWord# x#))+        | otherwise     = fromEnumError "Word32" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Word32 where+    quot    x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord32#` y#)+        | otherwise                 = divZeroError+    rem     x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord32#` y#)+        | otherwise                 = divZeroError+    div     x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord32#` y#)+        | otherwise                 = divZeroError+    mod     x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord32#` y#)+        | otherwise                 = divZeroError+    quotRem x@(W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))+        | otherwise                 = divZeroError+    divMod  x@(W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))+        | otherwise                 = divZeroError+    toInteger x@(W32# x#)+        | x <= fromIntegral (maxBound::Int)  = S# (word2Int# (word32ToWord# x#))+        | otherwise                 = case word32ToInteger# x# of (# s, d #) -> J# s d++instance Bits Word32 where+    {-# INLINE shift #-}++    (W32# x#) .&.   (W32# y#)  = W32# (x# `and32#` y#)+    (W32# x#) .|.   (W32# y#)  = W32# (x# `or32#`  y#)+    (W32# x#) `xor` (W32# y#)  = W32# (x# `xor32#` y#)+    complement (W32# x#)       = W32# (not32# x#)+    (W32# x#) `shift` (I# i#)+        | i# >=# 0#            = W32# (x# `shiftL32#` i#)+        | otherwise            = W32# (x# `shiftRL32#` negateInt# i#)+    (W32# x#) `rotate` (I# i#)+        | i'# ==# 0# = W32# x#+        | otherwise  = W32# ((x# `shiftL32#` i'#) `or32#`+                             (x# `shiftRL32#` (32# -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                = 32+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int->Word32"    fromIntegral = \(I#   x#) -> W32# (int32ToWord32# (intToInt32# x#))+"fromIntegral/Word->Word32"   fromIntegral = \(W#   x#) -> W32# (wordToWord32# x#)+"fromIntegral/Word32->Int"    fromIntegral = \(W32# x#) -> I#   (word2Int# (word32ToWord# x#))+"fromIntegral/Word32->Word"   fromIntegral = \(W32# x#) -> W#   (word32ToWord# x#)+"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32+  #-}++#else ++-- Word32 is represented in the same way as Word.+#if WORD_SIZE_IN_BITS > 32+-- Operations may assume and must ensure that it holds only values+-- from its logical range.+#endif++data Word32 = W32# Word# deriving (Eq, Ord)+-- ^ 32-bit unsigned integer type++instance Num Word32 where+    (W32# x#) + (W32# y#)  = W32# (narrow32Word# (x# `plusWord#` y#))+    (W32# x#) - (W32# y#)  = W32# (narrow32Word# (x# `minusWord#` y#))+    (W32# x#) * (W32# y#)  = W32# (narrow32Word# (x# `timesWord#` y#))+    negate (W32# x#)       = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#))))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W32# (narrow32Word# (integerToWord i))++instance Enum Word32 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word32"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word32"+    toEnum i@(I# i#)+        | i >= 0+#if WORD_SIZE_IN_BITS > 32+          && i <= fromIntegral (maxBound::Word32)+#endif+                        = W32# (int2Word# i#)+        | otherwise     = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)+#if WORD_SIZE_IN_BITS == 32+    fromEnum x@(W32# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# x#)+        | otherwise     = fromEnumError "Word32" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo+#else+    fromEnum (W32# x#)  = I# (word2Int# x#)+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen+#endif++instance Integral Word32 where+    quot    (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    rem     (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    div     (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    mod     (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    quotRem (W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    divMod  (W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    toInteger (W32# x#)+#if WORD_SIZE_IN_BITS == 32+        | i# >=# 0#                 = smallInteger i#+        | otherwise                 = wordToInteger x#+        where+        i# = word2Int# x#+#else+                                    = smallInteger (word2Int# x#)+#endif++instance Bits Word32 where+    {-# INLINE shift #-}++    (W32# x#) .&.   (W32# y#)  = W32# (x# `and#` y#)+    (W32# x#) .|.   (W32# y#)  = W32# (x# `or#`  y#)+    (W32# x#) `xor` (W32# y#)  = W32# (x# `xor#` y#)+    complement (W32# x#)       = W32# (x# `xor#` mb#) where W32# mb# = maxBound+    (W32# x#) `shift` (I# i#)+        | i# >=# 0#            = W32# (narrow32Word# (x# `shiftL#` i#))+        | otherwise            = W32# (x# `shiftRL#` negateInt# i#)+    (W32# x#) `rotate` (I# i#)+        | i'# ==# 0# = W32# x#+        | otherwise  = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (32# -# i'#))))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                = 32+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Word32"   fromIntegral = \(W8# x#) -> W32# x#+"fromIntegral/Word16->Word32"  fromIntegral = \(W16# x#) -> W32# x#+"fromIntegral/Word32->Word32"  fromIntegral = id :: Word32 -> Word32+"fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer+"fromIntegral/a->Word32"       fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#)+"fromIntegral/Word32->a"       fromIntegral = \(W32# x#) -> fromIntegral (W# x#)+  #-}++#endif++instance Show Word32 where+#if WORD_SIZE_IN_BITS < 33+    showsPrec p x = showsPrec p (toInteger x)+#else+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+#endif+++instance Real Word32 where+    toRational x = toInteger x % 1++instance Bounded Word32 where+    minBound = 0+    maxBound = 0xFFFFFFFF++instance Ix Word32 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word32 where  +#if WORD_SIZE_IN_BITS < 33+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]+#else+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]+#endif++------------------------------------------------------------------------+-- type Word64+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 64++data Word64 = W64# Word64#+-- ^ 64-bit unsigned integer type++instance Eq Word64 where+    (W64# x#) == (W64# y#) = x# `eqWord64#` y#+    (W64# x#) /= (W64# y#) = x# `neWord64#` y#++instance Ord Word64 where+    (W64# x#) <  (W64# y#) = x# `ltWord64#` y#+    (W64# x#) <= (W64# y#) = x# `leWord64#` y#+    (W64# x#) >  (W64# y#) = x# `gtWord64#` y#+    (W64# x#) >= (W64# y#) = x# `geWord64#` y#++instance Num Word64 where+    (W64# x#) + (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#))+    (W64# x#) - (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `minusInt64#` word64ToInt64# y#))+    (W64# x#) * (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `timesInt64#` word64ToInt64# y#))+    negate (W64# x#)       = W64# (int64ToWord64# (negateInt64# (word64ToInt64# x#)))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W64# (integerToWord64 i)++instance Enum Word64 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word64"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word64"+    toEnum i@(I# i#)+        | i >= 0        = W64# (wordToWord64# (int2Word# i#))+        | otherwise     = toEnumError "Word64" i (minBound::Word64, maxBound::Word64)+    fromEnum x@(W64# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# (word64ToWord# x#))+        | otherwise     = fromEnumError "Word64" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Word64 where+    quot    (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `quotWord64#` y#)+        | otherwise                 = divZeroError+    rem     (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `remWord64#` y#)+        | otherwise                 = divZeroError+    div     (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `quotWord64#` y#)+        | otherwise                 = divZeroError+    mod     (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `remWord64#` y#)+        | otherwise                 = divZeroError+    quotRem (W64# x#) y@(W64# y#)+        | y /= 0                    = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))+        | otherwise                 = divZeroError+    divMod  (W64# x#) y@(W64# y#)+        | y /= 0                    = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))+        | otherwise                 = divZeroError+    toInteger (W64# x#)             = word64ToInteger x#++instance Bits Word64 where+    {-# INLINE shift #-}++    (W64# x#) .&.   (W64# y#)  = W64# (x# `and64#` y#)+    (W64# x#) .|.   (W64# y#)  = W64# (x# `or64#`  y#)+    (W64# x#) `xor` (W64# y#)  = W64# (x# `xor64#` y#)+    complement (W64# x#)       = W64# (not64# x#)+    (W64# x#) `shift` (I# i#)+        | i# >=# 0#            = W64# (x# `shiftL64#` i#)+        | otherwise            = W64# (x# `shiftRL64#` negateInt# i#)+    (W64# x#) `rotate` (I# i#)+        | i'# ==# 0# = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`+                             (x# `uncheckedShiftRL64#` (64# -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                = 64+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++-- give the 64-bit shift operations the same treatment as the 32-bit+-- ones (see GHC.Base), namely we wrap them in tests to catch the+-- cases when we're shifting more than 64 bits to avoid unspecified+-- behaviour in the C shift operations.++shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64#++a `shiftL64#` b  | b >=# 64#  = wordToWord64# (int2Word# 0#)+                 | otherwise  = a `uncheckedShiftL64#` b++a `shiftRL64#` b | b >=# 64#  = wordToWord64# (int2Word# 0#)+                 | otherwise  = a `uncheckedShiftRL64#` b++{-# RULES+"fromIntegral/Int->Word64"    fromIntegral = \(I#   x#) -> W64# (int64ToWord64# (intToInt64# x#))+"fromIntegral/Word->Word64"   fromIntegral = \(W#   x#) -> W64# (wordToWord64# x#)+"fromIntegral/Word64->Int"    fromIntegral = \(W64# x#) -> I#   (word2Int# (word64ToWord# x#))+"fromIntegral/Word64->Word"   fromIntegral = \(W64# x#) -> W#   (word64ToWord# x#)+"fromIntegral/Word64->Word64" fromIntegral = id :: Word64 -> Word64+  #-}++#else++-- Word64 is represented in the same way as Word.+-- Operations may assume and must ensure that it holds only values+-- from its logical range.++data Word64 = W64# Word# deriving (Eq, Ord)+-- ^ 64-bit unsigned integer type++instance Num Word64 where+    (W64# x#) + (W64# y#)  = W64# (x# `plusWord#` y#)+    (W64# x#) - (W64# y#)  = W64# (x# `minusWord#` y#)+    (W64# x#) * (W64# y#)  = W64# (x# `timesWord#` y#)+    negate (W64# x#)       = W64# (int2Word# (negateInt# (word2Int# x#)))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W64# (integerToWord i)++instance Enum Word64 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word64"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word64"+    toEnum i@(I# i#)+        | i >= 0        = W64# (int2Word# i#)+        | otherwise     = toEnumError "Word64" i (minBound::Word64, maxBound::Word64)+    fromEnum x@(W64# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# x#)+        | otherwise     = fromEnumError "Word64" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Word64 where+    quot    (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    rem     (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    div     (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    mod     (W64# x#) y@(W64# y#)+        | y /= 0                    = W64# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    quotRem (W64# x#) y@(W64# y#)+        | y /= 0                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    divMod  (W64# x#) y@(W64# y#)+        | y /= 0                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    toInteger (W64# x#)+        | i# >=# 0#                 = smallInteger i#+        | otherwise                 = wordToInteger x#+        where+        i# = word2Int# x#++instance Bits Word64 where+    {-# INLINE shift #-}++    (W64# x#) .&.   (W64# y#)  = W64# (x# `and#` y#)+    (W64# x#) .|.   (W64# y#)  = W64# (x# `or#`  y#)+    (W64# x#) `xor` (W64# y#)  = W64# (x# `xor#` y#)+    complement (W64# x#)       = W64# (x# `xor#` mb#) where W64# mb# = maxBound+    (W64# x#) `shift` (I# i#)+        | i# >=# 0#            = W64# (x# `shiftL#` i#)+        | otherwise            = W64# (x# `shiftRL#` negateInt# i#)+    (W64# x#) `rotate` (I# i#)+        | i'# ==# 0# = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftL#` i'#) `or#`+                             (x# `uncheckedShiftRL#` (64# -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                = 64+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x#+"fromIntegral/Word64->a" fromIntegral = \(W64# x#) -> fromIntegral (W# x#)+  #-}++uncheckedShiftL64# :: Word# -> Int# -> Word#+uncheckedShiftL64#  = uncheckedShiftL#++uncheckedShiftRL64# :: Word# -> Int# -> Word#+uncheckedShiftRL64# = uncheckedShiftRL#++#endif++instance Show Word64 where+    showsPrec p x = showsPrec p (toInteger x)++instance Real Word64 where+    toRational x = toInteger x % 1++instance Bounded Word64 where+    minBound = 0+    maxBound = 0xFFFFFFFFFFFFFFFF++instance Ix Word64 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word64 where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
− lib/base/src/Lhc/ACIO.hs 
@@ -1,86 +0,0 @@-{-# OPTIONS_LHC -N  #-}-module Lhc.ACIO where--import Lhc.IORef-import Lhc.IO-import Lhc.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--Lhc 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 Lhc.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 Lhc.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/base/src/Lhc/Addr.hs 
@@ -1,84 +0,0 @@-{-# OPTIONS_LHC -N -fffi -funboxed-values -fm4 #-}--m4_include(Lhc/Order.m4)-m4_include(Foreign/Storable.m4)--module Lhc.Addr(-    Addr(..),-    FunAddr(..),-    Ptr(..),-    FunPtr(..),-    ptrFromAddr__,-    nullAddr,-    castPtr,-    nullFunAddr,-    plusAddr,-    addrToWordPtr,-    wordPtrToAddr,-    wordPtrToFunAddr,-    funAddrToWordPtr-    ) where--import Lhc.Int-import Data.Word-import Lhc.Prim-import Lhc.Types-import Lhc.Order-import Lhc.Basics-import Lhc.IO-import Foreign.Storable--data Addr = Addr BitsPtr_-data FunAddr = FunAddr BitsPtr_--newtype Ptr a = Ptr Addr-newtype FunPtr a = FunPtr FunAddr--nullAddr = Addr 0#-nullFunAddr = FunAddr 0#--INST_EQORDER(Addr,BitsPtr_)-INST_EQORDER(FunAddr,BitsPtr_)--INST_STORABLE(Addr,BitsPtr_,bits<ptr>)-INST_STORABLE(FunAddr,BitsPtr_,bits<ptr>)--{-# INLINE plusAddr #-}-plusAddr :: Addr -> Int -> Addr-plusAddr (Addr addr) off = case unboxInt off of-    off_ -> Addr (addr `plusWordPtr` intToPtr__ off_)--foreign import primitive "U2U" addrToWordPtr :: Addr -> WordPtr-foreign import primitive "U2U" wordPtrToAddr :: WordPtr -> Addr-foreign import primitive "U2U" wordPtrToFunAddr :: WordPtr -> FunAddr-foreign import primitive "U2U" funAddrToWordPtr :: FunAddr -> WordPtr--foreign import primitive "Sx" intToPtr__ :: Int__ -> BitsPtr_--foreign import primitive "Add" plusWordPtr :: BitsPtr_ -> BitsPtr_ -> BitsPtr_--ptrFromAddr__ :: Addr__ -> Ptr a-ptrFromAddr__ addr = Ptr (Addr addr)--instance Storable (Ptr a) where-    sizeOf (Ptr a) = sizeOf a-    alignment (Ptr a) = alignment a-    peek p = peek (castPtr p) `thenIO` (returnIO . Ptr)-    poke p (Ptr x) = poke (castPtr p) x--instance Eq (Ptr a) where-    Ptr a == Ptr b = a == b-    Ptr a /= Ptr b = a /= b--instance Ord (Ptr a) where-    compare (Ptr a) (Ptr b) = compare a b-    Ptr a <= Ptr b = a <= b-    Ptr a < Ptr b = a < b-    Ptr a > Ptr b = a > b-    Ptr a >= Ptr b = a >= b--castPtr :: Ptr a -> Ptr b-castPtr (Ptr addr) = Ptr addr--foreign import primitive "box" boxBool :: Bool__ -> Bool-
− lib/base/src/Lhc/Array.hs 
@@ -1,36 +0,0 @@-{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}-module Lhc.Array where--import Lhc.Basics-import Lhc.IO-import Lhc.Int----data MutArray__ :: * -> #-data Array__ :: * -> #--foreign import primitive newMutArray__      :: Int__ -> a -> UIO (MutArray__ a)-foreign import primitive newBlankMutArray__ :: Int__ -> UIO (MutArray__ a)-foreign import primitive copyArray__        :: Int__ -> Int__ -> Int__ -> Array__ a -> MutArray__ a -> UIO_-foreign import primitive copyMutArray__     :: Int__ -> Int__ -> Int__ -> MutArray__ a -> MutArray__ a -> UIO_-foreign import primitive readArray__        :: MutArray__ a -> Int__ -> UIO a-foreign import primitive writeArray__       :: MutArray__ a -> Int__ -> a -> UIO_-foreign import primitive indexArray__       :: Array__ a -> Int__ -> (# a #)---- these basically cast from a mutable to an immutable array and back again-foreign import primitive unsafeFreezeArray__ :: MutArray__ a -> UIO (Array__ a)-foreign import primitive unsafeThawArray__ :: Array__ a -> UIO (MutArray__ a)--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 newMutArray__ 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 -> case unsafeFreezeArray__ arr w  of (# _, r #) -> r-
− lib/base/src/Lhc/Basics.hs 
@@ -1,182 +0,0 @@-{-# OPTIONS_LHC -N -fffi #-}-module Lhc.Basics(module Lhc.Basics, module Lhc.Prim) where--import Lhc.Prim-import Lhc.Types-import Lhc.Int--data (->) :: ?? -> ? -> *--data Integer = Integer BitsMax_--type String = [Char]--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------------------------------- 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)--foreign import primitive "error.Prelude.undefined" undefined :: a--ord :: Char -> Int-ord (Char c) = boxInt c--chr :: Int -> Char-chr i = Char (unboxInt i)--unsafeChr :: Int -> Char-unsafeChr = chr--{--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)--}-
− lib/base/src/Lhc/Enum.hs 
@@ -1,132 +0,0 @@-{-# OPTIONS_LHC -N -fffi -funboxed-values #-}-module Lhc.Enum(Enum(..),Bounded(..)) where--- Enumeration and Bounded classes--import Lhc.Inst.PrimEnum()-import Data.Int-import Lhc.Types-import Lhc.Basics-import Lhc.Order-import Lhc.Int--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' < c    = minBound-                                    | otherwise = maxBound-    enumFromTo x y = f x where-        f x | x > y = []-            | otherwise = x:f (increment x)--    enumFromThenTo = efdtInt---------------------------------------------------------------------------- Shamelessly stolen from GHC.Enum--efdtInt :: Int -> Int -> Int -> [Int]--- [x1,x2..y]-efdtInt x1 x2 y- | x2 >= x1  = efdtIntUp x1 x2 y- | otherwise = efdtIntDn x1 x2 y---- Requires x2 >= x1-efdtIntUp :: Int -> Int -> Int -> [Int]-efdtIntUp x1 x2 y    -- Be careful about overflow!- | y < x2    = if y < x1 then [] else [x1]- | otherwise = -- Common case: x1 <= x2 <= y-               let delta = x2 `minus` x1 -- >= 0-                   y' = y `minus` delta  -- x1 <= y' <= y; hence y' is representable--                   -- Invariant: x <= y-                   -- Note that: z <= y' => z + delta won't overflow-                   -- so we are guaranteed not to overflow if/when we recurse-                   go_up x | x > y'   = [x]-                           | otherwise = x : go_up (x `plus` delta)-               in x1 : go_up x2---- Requires x2 <= x1-efdtIntDn :: Int -> Int -> Int -> [Int]-efdtIntDn x1 x2 y    -- Be careful about underflow!- | y > x2    = if y > x1 then [] else [x1]- | otherwise = -- Common case: x1 >= x2 >= y-               let delta = x2 `minus` x1 -- <= 0-                   y' = y `minus` delta  -- y <= y' <= x1; hence y' is representable--                   -- Invariant: x >= y-                   -- Note that: z >= y' => z + delta won't underflow-                   -- so we are guaranteed not to underflow if/when w-e recurse-                   go_dn x | x < y'   = [x]-                           | otherwise = x : go_dn (x `plus` delta)-               in x1 : go_dn x2---- End shameless theft--------------------------------------------------------------------------instance Enum Char where-    toEnum = chr-    fromEnum = ord-    enumFrom c        = [c .. maxBound::Char]-    enumFromThen c c' = [c, c' .. lastChar]-                      where lastChar :: Char-                            lastChar | c' < 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---instance Bounded Char where-    minBound = Char 0#-    maxBound = Char 0x10ffff#--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/base/src/Lhc/Float.hs 
@@ -1,228 +0,0 @@-{-# OPTIONS_LHC -N -fffi -fm4 #-}--module Lhc.Float(-    Float(..),-    Double(..),-    floatToDouble,-    doubleToFloat,-    Floating(..),-    RealFrac(..),-    RealFloat(..),-    rationalToDouble-    )-    where--import Lhc.Basics-import Lhc.Int-import Lhc.IO(error)-import Lhc.Num-import Lhc.Order-import Lhc.Types-import Lhc.Enum--infixr 8  **--data Float = Float Float32_-data Double = Double Float64_---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-foreign import primitive "box" boxBool :: Bool__ -> Bool---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 = boxBool (x `eq$2` y)-    $1 x /= $1 y = boxBool (x `neq$2` y)--instance Ord $1 where-    $1 x < $1 y = boxBool (flt$2 x y)-    $1 x > $1 y = boxBool (fgt$2 x y)-    $1 x <= $1 y = boxBool (flte$2 x y)-    $1 x >= $1 y = boxBool (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/base/src/Lhc/Handle.hs 
@@ -1,91 +0,0 @@-{-# OPTIONS_LHC -fffi -funboxed-values #-}-module Lhc.Handle(-    Handle(..),-    IOMode(..),-    stdin,-    stdout,-    stderr,-    withHandle,-    hClose,-    hIsOpen,-    openFile-    ) where--import Foreign.Ptr-import Foreign.Storable-import Foreign.C.Types-import Lhc.IO-import Lhc.Addr-import Foreign.C.String-import Foreign.Marshal.Utils-import Foreign.C.Error--data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode-    deriving(Eq, Ord, Bounded, Enum, Read, Show)--data Handle = Handle {-    handleName :: String,-    handleFile :: Ptr (Ptr Handle),-    handleIOMode :: IOMode-    }--instance Show Handle where-    showsPrec _ h s = handleName h ++ s--stdin, stdout, stderr :: Handle--make_builtin mode name std = Handle { handleName = "(" ++ name ++ ")", handleFile = std, handleIOMode = mode }--stdin = make_builtin ReadMode "stdin" c_stdin-stdout = make_builtin WriteMode "stdout" c_stdout-stderr = make_builtin WriteMode "stderr" c_stderr--{--stdin  = Handle (unsafePerformIO (peek c_stdin))-stdout = Handle (unsafePerformIO (peek c_stdout))-stderr = Handle (unsafePerformIO (peek c_stderr))--}--foreign import ccall "stdio.h &stdin" c_stdin :: Ptr (Ptr Handle)-foreign import ccall "stdio.h &stdout" c_stdout :: Ptr (Ptr Handle)-foreign import ccall "stdio.h &stderr" c_stderr :: Ptr (Ptr Handle)--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 -> c_fclose ptr >> 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 (toStr m)-    if ptr == nullPtr then throwErrnoFN "openFile" fp  else do-        pptr <- new ptr-        return Handle { handleName = fp, handleIOMode = m, handleFile = pptr }--toStr ReadMode = ptrFromAddr__ "r"#-toStr WriteMode = ptrFromAddr__ "w"#-toStr AppendMode = ptrFromAddr__ "a"#-toStr ReadWriteMode = ptrFromAddr__ "r+"#--foreign import ccall "stdio.h fclose" c_fclose :: Ptr Handle -> IO CInt-foreign import ccall "stdio.h fopen" c_fopen :: Ptr CChar -> Ptr CChar ->  IO (Ptr Handle)--
− lib/base/src/Lhc/Hole.hs 
@@ -1,36 +0,0 @@-{-# OPTIONS_LHC -fffi #-}--- | 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 Lhc.Hole(Hole(),newHole,fillHole,readHole,errorHole) where--import Lhc.IO--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/base/src/Lhc/IO.hs 
@@ -1,177 +0,0 @@-{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}--module Lhc.IO(-    IO(..),-    thenIO,-    thenIO_,-    returnIO,--    UIO(),-    UIO_(),--    World__(),-    catch,-    unIO,-    etaIO,-    dependingOn,-    fixIO,-    ioError,-    runExpr,-    runMain,-    runNoWrapper,-    exitFailure,-    strictReturn,-    unsafeInterleaveIO,-    error,-    IOError(),-    showIOError,-    userError,-    unsafePerformIO,-    unsafePerformIO'-    ) where--import Lhc.Prim-import Lhc.Basics-import Lhc.Order-import qualified Lhc.Options----- basic types---unIO :: IO a -> World__ -> (# World__, a #)-unIO (IO x) = x--type UIO a = World__ -> (# World__, a #)-type UIO_ = World__ -> World__---- | this ensures the world parameter is eta expanded out-{-# INLINE etaIO #-}-etaIO :: IO a -> IO a-etaIO x = IO $ \w -> unIO x w---- unsafe operations--unsafePerformIO :: IO a -> a-unsafePerformIO x = case newWorld__ x of-    world -> case errorContinuation x of-        IO y -> case y 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 = IO $ \w -> (# w , case action' w of (# _,  a #) -> a #)-    where IO action' = errorContinuation action----- IO Exception handling--newtype IOError = IOError String-    deriving(Eq)--showIOError :: IOError -> String-showIOError (IOError x) = x--userError       :: String  -> IOError-userError str	=  IOError  str--showError :: IOError -> IO b-showError (IOError z) = putErrLn z `thenIO_` exitFailure--errorContinuation :: IO a -> IO a-errorContinuation x = catch x showError--ioError    ::  IOError -> IO a-ioError e  = case Lhc.Options.target of-    Lhc.Options.GhcHs -> IO $ \w -> raiseIO__ e w-    _ -> showError e---catch :: IO a -> (IOError -> IO a) -> IO a-catch (IO m) k =  case Lhc.Options.target of-    Lhc.Options.GhcHs -> IO $ \s -> catch__ m (\ex -> unIO (k ex)) s-    _ -> IO m  -- no catching on other targets just yet----- IO fixpoint operation--data FixIO a = FixIO World__ a--fixIO :: (a -> IO a) -> IO a-fixIO k = IO $ \w -> let-            r = case k ans of-                    IO 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 $ \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 run = catch main $ \e ->-            putErrLn "\nUncaught Exception:" `thenIO_`-            putErrLn (showIOError e)         `thenIO_`-            exitFailure-----exitFailure :: IO a-exitFailure = IO $ \w -> exitFailure__ w--foreign import primitive exitFailure__ :: World__ -> (# World__, a #)---thenIO_ :: IO a -> IO b -> IO b-IO a `thenIO_` IO b = IO $ \w -> case a w of-    (# w', _ #) -> b w'--IO a `thenIO` b = IO $ \w -> case a w of-    (# w', v #) -> unIO (b v) w'--returnIO :: a -> IO a-returnIO x = IO $ \w -> (# w, x #)--{-# NOINLINE error #-}-error s = unsafePerformIO' $-    putErrLn "error:"  `thenIO_`-    putErrLn s         `thenIO_`-    exitFailure---- | no the implicit unsafeCoerce__ here!-foreign import primitive catch__ :: (World__ -> (# World__,a #)) -> (b -> World__ -> (# World__,a #)) -> World__ -> (# World__,a #)-foreign import primitive raiseIO__ :: a -> World__ -> (# World__,b #)---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 lhc_utf8_putchar" c_putwchar :: Int -> IO ()-
− lib/base/src/Lhc/Inst/Enum.hs 
@@ -1,128 +0,0 @@-{-# OPTIONS_LHC -N -fffi -funboxed-values -fm4 #-}--module Lhc.Inst.Enum() where--import Data.Word-import Data.Int-import Lhc.Enum-import Lhc.Num-import Lhc.Order-import Lhc.Types-import Lhc.IO(error)-import Lhc.Basics--------------------------------------------------------------------------- Shamelessly stolen from GHC.Enum--efdt :: Integral i => i -> i -> i -> [i]--- [x1,x2..y]-efdt x1 x2 y- | x2 >= x1  = efdtUp x1 x2 y- | otherwise = efdtDn x1 x2 y---- Requires x2 >= x1-efdtUp :: Integral i => i -> i -> i -> [i]-efdtUp x1 x2 y    -- Be careful about overflow!- | y < x2    = if y < x1 then [] else [x1]- | otherwise = -- Common case: x1 <= x2 <= y-               let delta = x2 - x1 -- >= 0-                   y' = y - delta  -- x1 <= y' <= y; hence y' is representable--                   -- Invariant: x <= y-                   -- Note that: z <= y' => z + delta won't overflow-                   -- so we are guaranteed not to overflow if/when we recurse-                   go_up x | x > y'   = [x]-                           | otherwise = x : go_up (x + delta)-               in x1 : go_up x2---- Requires x2 <= x1-efdtDn :: Integral i => i -> i -> i -> [i]-efdtDn x1 x2 y    -- Be careful about underflow!- | y > x2    = if y > x1 then [] else [x1]- | otherwise = -- Common case: x1 >= x2 >= y-               let delta = x2 - x1 -- <= 0-                   y' = y - delta  -- y <= y' <= x1; hence y' is representable--                   -- Invariant: x >= y-                   -- Note that: z >= y' => z + delta won't underflow-                   -- so we are guaranteed not to underflow if/when w-e recurse-                   go_dn x | x < y'   = [x]-                           | otherwise = x : go_dn (x + delta)-               in x1 : go_dn x2---- End shameless theft--------------------------------------------------------------------------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-                                 | otherwise = maxBound-    enumFromTo x y = f x where-        f x | x > y = []-            | otherwise = x:f (x + 1)-    enumFromThenTo x1 x2 y = x1 `seq` x2 `seq` y `seq` efdt x1 x2 y--foreign import primitive "increment" increment$1 :: $1 -> $1-foreign import primitive "decrement" decrement$1 :: $1 -> $1--}})--ENUMINST(Word)-ENUMINST(Word8)-ENUMINST(Word16)-ENUMINST(Word32)-ENUMINST(Word64)-ENUMINST(WordMax)--ENUMINST(Int8)-ENUMINST(Int16)-ENUMINST(Int32)-ENUMINST(Int64)-{-ENUMINST(IntPtr)-}-ENUMINST(Integer)---instance Enum () where-    succ _      = error "Prelude.Enum.().succ: bad argument"-    pred _      = error "Prelude.Enum.().pred: bad argument"--    toEnum x | x == 0 = ()-             | otherwise    = error "Prelude.Enum.().toEnum: bad argument"--    fromEnum () = 0-    enumFrom () 	= [()]-    enumFromThen () () 	= let many = ():many in many-    enumFromTo () () 	= [()]-    enumFromThenTo () () () = let many = ():many in many--m4_define(INST_BOUNDED,{{-instance Bounded $1 where-    minBound = $1 (minBound$1 0#)-    maxBound = $1 (maxBound$1 0#)--foreign import primitive "minBound.$3" minBound$1 :: $2 -> $2-foreign import primitive "maxBound.$3" maxBound$1 :: $2 -> $2-}})--INST_BOUNDED(Int,Bits32_,bits32)-INST_BOUNDED(Int8,Bits8_,bits8)-INST_BOUNDED(Int16,Bits16_,bits16)-INST_BOUNDED(Int32,Bits32_,bits32)-INST_BOUNDED(Int64,Bits64_,bits64)--INST_BOUNDED(Word,Bits32_,bits32)-INST_BOUNDED(Word8,Bits8_,bits8)-INST_BOUNDED(Word16,Bits16_,bits16)-INST_BOUNDED(Word32,Bits32_,bits32)-INST_BOUNDED(Word64,Bits64_,bits64)-INST_BOUNDED(WordMax,BitsMax_,bits<max>)---- Lemmih 2009.01.22: This instance shouldn't exist. Delete it.-INST_BOUNDED(Integer,BitsMax_,bits<max>)
− lib/base/src/Lhc/Inst/Num.m4 
@@ -1,37 +0,0 @@-m4_define(NUMINST,{{-instance Num $1 where-    $1 x + $1 y = $1 (add_$1 x y)-    $1 x - $1 y = $1 (sub_$1 x y)-    $1 x * $1 y = $1 (mul_$1 x y)-    -    negate ($1 x) = $1 (neg_$1 x)-    -    abs    x | x < 0     = -x-             | otherwise =  x-    -    signum 0 = 0-    signum x | x < 0     = -1-             | otherwise =  1--    fromInteger (Integer x) = $1 (bitsmax_to_$1 x)-    fromInt (Int x) = $1 (bits32_to_$1 x)--instance Integral $1 where-    $1 n `quot` $1 d = $1 (div_$1 n d)-    $1 n `rem`  $1 d = $1 (mod_$1 n d)--    toInteger ($1 x) = Integer (max_from_$1 x)-    toInt ($1 x) = Int (bits32_from_$1 x)--foreign import primitive "Neg" neg_$1 :: $2 -> $2-foreign import primitive "Add" add_$1 :: $2 -> $2 -> $2-foreign import primitive "Sub" sub_$1 :: $2 -> $2 -> $2-foreign import primitive "Mul" mul_$1 :: $2 -> $2 -> $2-foreign import primitive "$3Div" div_$1 :: $2 -> $2 -> $2-foreign import primitive "$3Mod" mod_$1 :: $2 -> $2 -> $2--foreign import primitive "I2I" bitsmax_to_$1 :: BitsMax_ -> $2-foreign import primitive "I2I" bits32_to_$1 :: Bits32_ -> $2-foreign import primitive "I2I" max_from_$1 :: $2 -> BitsMax_-foreign import primitive "I2I" bits32_from_$1 :: $2 -> Bits32_-}})
− lib/base/src/Lhc/Inst/PrimEnum.hs 
@@ -1,88 +0,0 @@-{-# OPTIONS_LHC -N -fffi -funboxed-values #-}---- | helper routines for deriving(Enum) instances--- these routines help out the compiler when--- deriving enums.--module Lhc.Inst.PrimEnum(enum_succ,enum_pred,enum_fromTo,enum_fromThen,enum_fromThenTo,enum_toEnum,enum_from) where---import Lhc.Prim-import Lhc.Int-import Lhc.Types---{-# 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_)--foreign import primitive "error.toEnum: out of range" toEnumError :: a-foreign import primitive "error.succ: out of range" succError :: a-foreign import primitive "error.pred: out of range" predError :: a-foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__--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--foreign import primitive "Eq"         enumEq  :: Enum__ -> Enum__ -> Bool__-foreign import primitive "Gt"         enumGt  :: Enum__ -> Enum__ -> Bool__-foreign import primitive "Lt"         enumLt  :: Enum__ -> Enum__ -> Bool__-foreign import primitive "Gte"        enumGte :: Enum__ -> Enum__ -> Bool__-foreign import primitive "Add"        enumAdd :: Enum__ -> Enum__ -> Enum__-foreign import primitive "Sub"        enumSub :: Enum__ -> Enum__ -> Enum__-foreign import primitive "increment"  enumInc :: Enum__ -> Enum__-foreign import primitive "decrement"  enumDec :: Enum__ -> Enum__-foreign import primitive "U2U"        intToEnum :: Int__ -> Enum__
− lib/base/src/Lhc/Inst/Read.hs 
@@ -1,55 +0,0 @@-{-# OPTIONS_LHC -N -fm4 #-}--module Lhc.Inst.Read() where--import Prelude.Text-import Data.Int-import Lhc.Basics-import Data.Word-import Lhc.Order-import Lhc.Float-import Prelude.Float-import Lhc.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/base/src/Lhc/Inst/Show.hs 
@@ -1,72 +0,0 @@-{-# OPTIONS_LHC -N #-}--module Lhc.Inst.Show() where--import Data.Int-import Data.Word-import Lhc.Basics-import Lhc.Num-import Lhc.Order-import Lhc.Enum-import Lhc.Show---- we convert them to Word or WordMax so the showIntAtBase specialization can occur.--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----- SamB 2009.01.24: FIXME these could be more efficient if we re-did the branch structure like in GHC.Int, I think-instance Show Int where-    showsPrec p x-        | x == minBound = showParen (p > 6) (showChar '-' . showWord (fromIntegral x :: Word))-        | x < 0         = showParen (p > 6) (showChar '-' . showWord (fromIntegral $ negate x :: Word))-        | otherwise = showWord (fromIntegral x :: Word)--instance Show Integer where-    showsPrec p x-        | x == minBound = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral x :: WordMax))-        | x < 0         = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral $ negate x :: WordMax))-        | otherwise     = 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)----- 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/base/src/Lhc/Inst/Storable.hs 
@@ -1,22 +0,0 @@-{-# OPTIONS_LHC -fm4 -N -fffi -funboxed-tuples -funboxed-values #-}-module Lhc.Inst.Storable where--m4_include(Foreign/Storable.m4)--import Lhc.Types-import Lhc.Float-import Foreign.Storable-import Lhc.Prim-import Lhc.Basics-import Lhc.Addr-import Lhc.Int-import Lhc.IO---INST_STORABLE(Int8,Bits8_,bits8)-INST_STORABLE(Int32,Bits32_,bits32)-INST_STORABLE(Word64,Bits64_,bits64)-INST_STORABLE(Float,Float32_,fbits32)-INST_STORABLE(Double,Float64_,fbits64)--
− lib/base/src/Lhc/Int.hs 
@@ -1,19 +0,0 @@-{-# OPTIONS_LHC -N -fffi #-}---- just a few basic operations on integers to jumpstart things-module Lhc.Int(Int(),Int__(),increment,decrement,plus,minus,times,divide,modulus,zero,one,boxInt,unboxInt) where--import Lhc.Prim(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 "Div" divide    :: Int -> Int -> Int-foreign import primitive "Mod" modulus   :: 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/base/src/Lhc/JumpPoint.hs 
@@ -1,33 +0,0 @@-{-# OPTIONS_LHC -fffi #-}-module Lhc.JumpPoint(JumpPoint(), withJumpPoint__, jumpJumpPoint__, errorJumpPoint) where--import Lhc.IO-import Lhc.Addr--newtype JumpPoint = JumpPoint Addr----- | 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 <- lhc_setjmp jp-    r <- action jp (r /= 0)-    _free p-    return r--jumpJumpPoint__ :: JumpPoint -> IO a-jumpJumpPoint__ jp = lhc_longjmp  jp >> return (error "jumpJumpPoint__")---- | jumping to this jumppoint will always abort the program.-foreign import ccall "&lhc_uncaught" errorJumpPoint :: JumpPoint--foreign import ccall lhc_setjmp :: JumpPoint -> IO Int-foreign import ccall lhc_longjmp :: JumpPoint -> IO ()-foreign import primitive "const.sizeof(jmp_buf)" jmp_buf_size  :: Int-foreign import ccall "malloc.h malloc" _malloc :: Int -> IO Addr-foreign import ccall "malloc.h free" _free :: Addr -> IO ()---
− lib/base/src/Lhc/List.hs 
@@ -1,319 +0,0 @@-{-# OPTIONS_LHC -N #-}-module Lhc.List where--import Lhc.Basics-import Lhc.IO(error)-import Lhc.Int-import Lhc.Order--import Lhc.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::Addr__) . 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 ys---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 #-}--{--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)-
− lib/base/src/Lhc/Maybe.hs 
@@ -1,36 +0,0 @@-{-# OPTIONS_LHC -N -fffi #-}-module Lhc.Maybe where--import Lhc.Monad-import Lhc.Order-import Lhc.Show-import Lhc.List-import Lhc.Basics-import Lhc.Num--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)------ Maybe--- need to add Read instance--data Maybe a  =  Nothing | Just a-    deriving (Eq, Ord, Show)--maybe :: b -> (a -> b) -> Maybe a -> b-maybe n f m = case m of-    Just x -> f x-    Nothing -> n--
− lib/base/src/Lhc/Monad.hs 
@@ -1,89 +0,0 @@-{-# OPTIONS_LHC -N -funboxed-tuples #-}--module Lhc.Monad where--import Lhc.Basics-import Lhc.IO---- Monadic classes--infixl 1  >>, >>=-infixr 1  =<<--class Functor f  where-    fmap              :: (a -> b) -> f a -> f b--{- 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 IO where-    return x = IO $ \w -> (# w, x #)-    IO x >>= f = IO $ \w -> case x w of-        (# w, v #) -> case f v of-            IO g -> g w-    IO x >> IO y = IO $ \w -> case x w of-        (# w,  _ #) -> y w-    fail s = ioError $ userError s--instance Functor IO where-    fmap f a = a >>= \x -> return (f x)--
− lib/base/src/Lhc/Num.hs 
@@ -1,128 +0,0 @@-{-# OPTIONS_LHC -N -fffi -fm4 #-}-module Lhc.Num where--import Lhc.Types-import Lhc.Basics-import Lhc.Order-import Lhc.Show-import Lhc.IO(error)-import Lhc.Enum-import Lhc.Float---infixl 7 :%-infixl 7  *  , /, `quot`, `rem`, `div`, `mod`-infixl 6  +, ---data  Ratio a  = !a :% !a-type  Rational = Ratio Integer--numerator, denominator  :: Ratio a -> a-numerator (x :% _)      =  x-denominator (_ :% y)    =  y---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 (toInteger i)-    fromInteger x = fromInt (toInt x)--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       =  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)---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              =  not . even--m4_include(Lhc/Inst/Num.m4)--NUMINST(Int,Bits32_)-NUMINST(Int8,Bits8_)-NUMINST(Int16,Bits16_)-NUMINST(Int32,Bits32_)-NUMINST(Int64,Bits64_)-NUMINST(IntPtr,BitsPtr_)-NUMINST(Integer,BitsMax_)--NUMINST(Word,Bits32_,U)-NUMINST(Word8,Bits8_,U)-NUMINST(WordMax,BitsMax_,U)-NUMINST(Word16,Bits16_,U)-NUMINST(Word32,Bits32_,U)-NUMINST(Word64,Bits64_,U)-NUMINST(WordPtr,BitsPtr_,U)-
− lib/base/src/Lhc/Options.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_LHC -N -fffi #-}--module Lhc.Options(target,Target(..)) where--data Target = Grin | GhcHs | DotNet | Java---{-# NOINLINE target #-}-target :: Target-target = unknown_target--foreign import primitive unknown_target :: Target-
− lib/base/src/Lhc/Order.hs 
@@ -1,201 +0,0 @@-{-# OPTIONS_LHC -N -fffi -fm4 #-}--module Lhc.Order(-    Bool(..),-    Ordering(..),-    Eq(..),-    Ord(..),-    (&&),-    (||),-    not,-    otherwise-    ) where--import Lhc.Types-import Lhc.Enum-import Lhc.Basics-import Lhc.Inst.Enum--data Bool = False | True-    deriving (Eq, Ord, Bounded, Enum)--data  Ordering    =  LT | EQ | GT-    deriving (Eq, Ord, Bounded, Enum)--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-                | otherwise = GT--    x <= y  = compare x y /= GT-    x <  y  = compare x y == LT-    x >= y  = compare x y /= LT-    x >  y  = compare x y == GT--    -- Note that (min x y, max x y) = (x,y) or (y,x)-    max x y | x <= y    =  y-            | otherwise =  x-    min x y | x <= y    =  x-            | otherwise =  y---instance Eq () where-    () == () = True-    () /= () = False--instance Ord () where-    () <= () = True-    () <  () = False-    () >= () = True-    () >  () = False-    max () () = ()-    min () () = ()-    compare () () = EQ--instance Bounded () where-    minBound = ()-    maxBound = ()--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)--m4_include(Lhc/Order.m4)--INST_EQORDER(Word8,Bits8_,U)-INST_EQORDER(Word16,Bits16_,U)-INST_EQORDER(Word32,Bits32_,U)-INST_EQORDER(Word64,Bits64_,U)-INST_EQORDER(WordPtr,BitsPtr_,U)--INST_EQORDER(Int8,Bits8_)-INST_EQORDER(Int16,Bits16_)-INST_EQORDER(Int32,Bits32_)-INST_EQORDER(Int64,Bits64_)-INST_EQORDER(IntPtr,BitsPtr_)--instance Eq Int where-    Int x == Int y = boxBool (bits32Eq x y)-    Int x /= Int y = boxBool (bits32NEq x y)--instance Ord Int where-    Int x < Int y = boxBool (bits32Lt x y)-    Int x > Int y = boxBool (bits32Gt x y)-    Int x <= Int y = boxBool (bits32Lte x y)-    Int x >= Int y = boxBool (bits32Gte x y)--instance Eq Word where-    Word x == Word y = boxBool (bits32Eq x y)-    Word x /= Word y = boxBool (bits32NEq x y)--instance Ord Word where-    Word x < Word y = boxBool (bits32Lt x y)-    Word x > Word y = boxBool (bits32Gt x y)-    Word x <= Word y = boxBool (bits32Lte x y)-    Word x >= Word y = boxBool (bits32Gte x y)--instance Eq Char where-    Char x == Char y = boxBool (bits32Eq x y)-    Char x /= Char y = boxBool (bits32NEq x y)--instance Ord Char where-    Char x < Char y = boxBool (bits32ULt x y)-    Char x > Char y = boxBool (bits32UGt x y)-    Char x <= Char y = boxBool (bits32ULte x y)-    Char x >= Char y = boxBool (bits32UGte x y)---instance Eq Integer where-    Integer x == Integer y = boxBool (bitsmaxEq x y)-    Integer x /= Integer y = boxBool (bitsmaxNEq x y)--instance Ord Integer where-    Integer x < Integer y = boxBool (bitsmaxLt x y)-    Integer x > Integer y = boxBool (bitsmaxGt x y)-    Integer x <= Integer y = boxBool (bitsmaxLte x y)-    Integer x >= Integer y = boxBool (bitsmaxGte x y)--instance Eq WordMax where-    WordMax x == WordMax y = boxBool (bitsmaxEq x y)-    WordMax x /= WordMax y = boxBool (bitsmaxNEq x y)--instance Ord WordMax where-    WordMax x < WordMax y = boxBool (bitsmaxLt x y)-    WordMax x > WordMax y = boxBool (bitsmaxGt x y)-    WordMax x <= WordMax y = boxBool (bitsmaxLte x y)-    WordMax x >= WordMax y = boxBool (bitsmaxGte x y)---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---foreign import primitive "Eq" bits32Eq :: Int__ -> Int__ -> Bool__-foreign import primitive "NEq" bits32NEq :: Int__ -> Int__ -> Bool__-foreign import primitive "Lt" bits32Lt :: Int__ -> Int__ -> Bool__-foreign import primitive "Lte" bits32Lte :: Int__ -> Int__ -> Bool__-foreign import primitive "Gt" bits32Gt :: Int__ -> Int__ -> Bool__-foreign import primitive "Gte" bits32Gte :: Int__ -> Int__ -> Bool__-foreign import primitive "ULt" bits32ULt :: Char__ -> Char__ -> Bool__-foreign import primitive "ULte" bits32ULte :: Char__ -> Char__ -> Bool__-foreign import primitive "UGt" bits32UGt :: Char__ -> Char__ -> Bool__-foreign import primitive "UGte" bits32UGte :: Char__ -> Char__ -> Bool__--foreign import primitive "Eq" bitsmaxEq :: BitsMax_ -> BitsMax_ -> Bool__-foreign import primitive "NEq" bitsmaxNEq :: BitsMax_ -> BitsMax_ -> Bool__-foreign import primitive "Lt" bitsmaxLt :: BitsMax_ -> BitsMax_ -> Bool__-foreign import primitive "Lte" bitsmaxLte :: BitsMax_ -> BitsMax_ -> Bool__-foreign import primitive "Gt" bitsmaxGt :: BitsMax_ -> BitsMax_ -> Bool__-foreign import primitive "Gte" bitsmaxGte :: BitsMax_ -> BitsMax_ -> Bool__--foreign import primitive "box" boxBool :: Bool__ -> Bool-
− lib/base/src/Lhc/Order.m4 
@@ -1,33 +0,0 @@-m4_divert(-1)-m4_dnl simple macros for defining instances for classes in Lhc.Order--m4_define(INST_EQ,{{-instance Eq $1 where-    $1 x == $1 y = boxBool (equals$1 x y)-    $1 x /= $1 y = boxBool (nequals$1 x y)--foreign import primitive "Eq" equals$1 :: $2 -> $2 -> Bool__-foreign import primitive "NEq" nequals$1 :: $2 -> $2 -> Bool__--}})---m4_define(INST_ORDER,{{-instance Ord $1 where-    $1 x < $1 y = boxBool (lt$1 x y)-    $1 x > $1 y = boxBool (gt$1 x y)-    $1 x <= $1 y = boxBool (lte$1 x y)-    $1 x >= $1 y = boxBool (gte$1 x y)--foreign import primitive "$3Lt" lt$1   :: $2 -> $2 -> Bool__-foreign import primitive "$3Lte" lte$1 :: $2 -> $2 -> Bool__-foreign import primitive "$3Gt" gt$1   :: $2 -> $2 -> Bool__-foreign import primitive "$3Gte" gte$1 :: $2 -> $2 -> Bool__--}})--m4_define(INST_EQORDER,{{INST_EQ($1,$2)INST_ORDER($1,$2,$3)}})--m4_divert--
− lib/base/src/Lhc/Prim.hs 
@@ -1,51 +0,0 @@-{-# OPTIONS_LHC -N -fffi -funboxed-tuples #-}-module Lhc.Prim where---- this module is always included in all programs compiled by lhc. it defines some things that are needed to make lhc work at all.--import Lhc.String-import Lhc.Types--infixr 5  :-data [] a =  a : ([] a) | []--newtype IO a = IO (World__ -> (# World__, a #))--data World__ :: #--data Int   = Int   Bits32_-data Int8  = Int8  Bits8_-data Int16 = Int16 Bits16_-data Int32 = Int32 Bits32_-data Int64 = Int64 Bits64_-data IntPtr = IntPtr BitsPtr_--data Word = Word Word__-data WordMax = WordMax BitsMax_-data Word8  = Word8 Bits8_-data Word16 = Word16 Bits16_-data Word32 = Word32 Bits32_-data Word64 = Word64 Bits64_-data WordPtr = WordPtr BitsPtr_-data Char = Char Char__--type Bool__ = Bits16_ -- Change to Bits1_ when the time comes-type Addr__ = BitsPtr_-type Int__  = Bits32_-type Word__ = Bits32_-type Char__ = Bits32_-type Enum__ = Bits16_----- | this is wrapped around arbitrary expressions and just evaluates them to whnf-foreign import primitive "seq" runRaw :: a -> World__ -> World__---- | when no exception wrapper is wanted-runNoWrapper :: IO a -> World__ -> World__-runNoWrapper (IO run) w = case run w of (# w, _ #) -> w---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 :: forall a b. a -> b -> a
− lib/base/src/Lhc/Show.hs 
@@ -1,67 +0,0 @@-{-# OPTIONS_LHC -N #-}-module Lhc.Show where--import Lhc.Int-import Lhc.Order-import Lhc.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/base/src/Lhc/String.hs 
@@ -1,103 +0,0 @@--- module for things dealing with string constants needed by the compiler internally-{-# OPTIONS_LHC -N -fffi -funboxed-values #-}-module Lhc.String(-    eqString,-    eqUnpackedString,-    unpackStringFoldr,-    eqSingleChar,-    unpackString-    )where---import Lhc.Prim---- TODO make it handle full UTF8--{-# 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))--{--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---}--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--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-        0# -> 0#-        uc -> case equalsChar uc c of-            0# -> 0#-            1# -> f (increment offset) cs---- returns it in an Char__ even though it is just a byte-foreign import primitive constPeekByte :: Addr__ -> Char__---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__-----
− lib/base/src/Lhc/Text/Read.hs 
@@ -1,122 +0,0 @@-{-# OPTIONS_LHC -N #-}-module Lhc.Text.Read where--import Lhc.Basics-import Lhc.Order-import Lhc.Int-import Lhc.List-import Prelude.CType--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]]-
− lib/base/src/Lhc/Tuples.hs 
@@ -1,115 +0,0 @@-{-# OPTIONS_LHC -N #-}---- | A place to collect the tuple instances.--module Lhc.Tuples where--import Lhc.Basics-import Lhc.Show-import Lhc.Order-import Lhc.List-import Lhc.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 (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/base/src/Lhc/Types.hs 
@@ -1,20 +0,0 @@-{-# OPTIONS_LHC -N  #-}-module Lhc.Types where--data Bits1_ :: #--data Bits8_   :: #-data Bits16_  :: #-data Bits32_  :: #-data Bits64_  :: #-data Bits128_ :: #-data BitsPtr_ :: #-data BitsMax_ :: #-data BitsShort_ :: #-data BitsInt_ :: #-data BitsSize_t_ :: #--data Float32_ :: #-data Float64_ :: #-data Float80_ :: #-data Float128_ :: #
lib/base/src/Numeric.hs view
@@ -1,360 +1,219 @@-module Numeric(fromRat,-               showSigned, showIntAtBase,-               showInt, showOct, showHex,-               readSigned, readInt,-               readDec, readOct, readHex,-               floatToDigits,-               showEFloat, showFFloat, showGFloat, showFloat,-               readFloat, lexDigits) where--import Data.Word-import Prelude.CType   ( isDigit, isOctDigit, isHexDigit-                   , digitToInt, intToDigit )-import Data.Ratio  ( (%), numerator, denominator )---import Array  ( (!), Array, array )-import Prelude.Text-import Lhc.Text.Read---- 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+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Numeric+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Odds and ends, mostly functions for reading and showing+-- 'RealFloat'-like kind of values.+--+----------------------------------------------------------------------------- -expts :: Array Int Integer-expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]--}+module Numeric ( --- 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+        -- * Showing +        showSigned,       -- :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS --- Misc utilities to show integers and floats-{-# SPECIALIZE showSigned :: (Int -> ShowS) -> Int -> Int -> ShowS #-}-{-# SPECIALIZE showSigned :: (Integer -> ShowS) -> Int -> Integer -> ShowS #-}+        showIntAtBase,    -- :: Integral a => a -> (a -> Char) -> a -> ShowS+        showInt,          -- :: Integral a => a -> ShowS+        showHex,          -- :: Integral a => a -> ShowS+        showOct,          -- :: Integral a => a -> 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+        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 -{-# INLINE showInt #-}+        floatToDigits,    -- :: (RealFloat a) => Integer -> a -> ([Int], Int) --- 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+        -- * Reading -{-# SPECIALIZE showIntAtBase :: Word -> (Int -> Char) -> Word -> ShowS #-}-{-# SPECIALIZE showIntAtBase :: WordMax -> (Int -> Char) -> WordMax -> ShowS #-}+        -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase',+        -- and 'readDec' is the \`dual\' of 'showInt'.+        -- The inconsistent naming is a historical accident. +        readSigned,       -- :: (Real a) => ReadS a -> ReadS a -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+        readInt,          -- :: (Integral a) => a -> (Char -> Bool)+                          --         -> (Char -> Int) -> ReadS a+        readDec,          -- :: (Integral a) => ReadS a+        readOct,          -- :: (Integral a) => ReadS a+        readHex,          -- :: (Integral a) => ReadS a +        readFloat,        -- :: (RealFloat a) => ReadS a -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]+        lexDigits,        -- :: ReadS String +        -- * Miscellaneous --- readInt reads a string of digits using an arbitrary base.--- Leading minus signs must be handled elsewhere.+        fromRat,          -- :: (RealFloat a) => Rational -> a -{-# SPECIALIZE readInt :: Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int #-}-{-# SPECIALIZE readInt :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer #-}+        ) where -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 ]+#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Read+import GHC.Real+import GHC.Float+import GHC.Num+import GHC.Show+import Data.Maybe+import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail )+import qualified Text.Read.Lex as L+#else+import Data.Char+#endif --- 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+#ifdef __HUGS__+import Hugs.Prelude+import Hugs.Numeric+#endif +#ifdef __GLASGOW_HASKELL__+-- -----------------------------------------------------------------------------+-- Reading -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+-- | Reads an /unsigned/ 'Integral' value in an arbitrary base.+readInt :: Num a+  => a                  -- ^ the base+  -> (Char -> Bool)     -- ^ a predicate distinguishing valid digits in this base+  -> (Char -> Int)      -- ^ a function converting a valid digit character to an 'Int'+  -> ReadS a+readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit) -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+-- | Read an unsigned number in octal notation.+readOct :: Num a => ReadS a+readOct = readP_to_S L.readOctP --- These are the format types.  This type is not exported.+-- | Read an unsigned number in decimal notation.+readDec :: Num a => ReadS a+readDec = readP_to_S L.readDecP -data FFFormat = FFExponent | FFFixed | FFGeneric+-- | Read an unsigned number in hexadecimal notation.+-- Both upper or lower case letters are allowed.+readHex :: Num a => ReadS a+readHex = readP_to_S L.readHexP  -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)+-- | Reads an /unsigned/ 'RealFrac' value,+-- expressed in decimal scientific notation.+readFloat :: RealFrac a => ReadS a+readFloat = readP_to_S readFloatP -    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)+readFloatP :: RealFrac a => ReadP a+readFloatP =+  do tok <- L.lex+     case tok of+       L.Rat y  -> return (fromRational y)+       L.Int i  -> return (fromInteger i)+       _        -> pfail -              Just dec ->-                let dec' = max dec 1 in-                case is of-                  [] -> '0':'.':take dec' (repeat '0') ++ "e0"-                  _ ->-                    let (ei, is') = roundTo base (dec'+1) is-                        d:ds = map intToDigit-                                   (if ei > 0 then init is' else is')-                    in d:'.':ds  ++ "e" ++ show (e-1+ei)+-- It's turgid to have readSigned work using list comprehensions,+-- but it's specified as a ReadS to ReadS transformer+-- With a bit of luck no one will use it. -          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)+-- | Reads a /signed/ 'Real' value, given a reader for an unsigned value.+readSigned :: (Real a) => ReadS a -> ReadS a+readSigned readPos = readParen False read'+                     where read' r  = read'' r +++                                      (do+                                        ("-",s) <- lex r+                                        (x,t)   <- read'' s+                                        return (-x,t))+                           read'' r = do+                               (str,s) <- lex r+                               (n,"")  <- readPos str+                               return (n,s) -               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+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 > 0 then is' else 0:is')-                   in  d : mkdot0 ds-            where-              mk0 "" = "0"        -- Print 0.34, not .34-              mk0 s  = s+-- -----------------------------------------------------------------------------+-- Showing -              mkdot0 "" = ""       -- Print 34, not 34.-              mkdot0 s  = '.' : s  -- when the format specifies no-			           -- digits after the decimal point+-- | Show /non-negative/ 'Integral' numbers in base 10.+showInt :: Integral a => a -> ShowS+showInt n0 cs0+    | n0 < 0    = error "Numeric.showInt: can't show negative numbers"+    | otherwise = go n0 cs0+    where+    go n cs+        | n < 10    = case unsafeChr (ord '0' + fromIntegral n) of+            c@(C# _) -> c:cs+        | otherwise = case unsafeChr (ord '0' + fromIntegral r) of+            c@(C# _) -> go q (c:cs)+        where+        (q,r) = n `quotRem` 10 +-- Controlling the format and precision of floats. The code that+-- implements the formatting itself is in @PrelNum@ to avoid+-- mutual module deps. -roundTo :: Int -> Int -> [Int] -> (Int, [Int])-roundTo base d is | base `seq` d `seq` True = case f d is of-                (0, is) -> (0, is)-                (1, is) -> (1, 1 : is)-  where b2 = base `div` 2-        f n [] = (0, replicate n 0)-        f 0 (i:_) = (if i >= b2 then 1 else 0, [])-        f d (i:is) =-            let (c, ds) = f (d-1) is-                i' = c + i-            in  if i' == base then (1, 0:ds) else (0, i':ds)+{-# SPECIALIZE showEFloat ::+        Maybe Int -> Float  -> ShowS,+        Maybe Int -> Double -> ShowS #-}+{-# SPECIALIZE showFFloat ::+        Maybe Int -> Float  -> ShowS,+        Maybe Int -> Double -> ShowS #-}+{-# SPECIALIZE showGFloat ::+        Maybe Int -> Float  -> ShowS,+        Maybe Int -> Double -> ShowS #-} +-- | Show a signed 'RealFloat' value+-- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@). ----- 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.+-- In the call @'showEFloat' digs val@, if @digs@ is 'Nothing',+-- the value is shown to full precision; if @digs@ is @'Just' d@,+-- then at most @d@ digits after the decimal point are shown.+showEFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS --- 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+-- | Show a signed 'RealFloat' value+-- using standard decimal notation (e.g. @245000@, @0.0015@). ----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.+-- In the call @'showFFloat' digs val@, if @digs@ is 'Nothing',+-- the value is shown to full precision; if @digs@ is @'Just' d@,+-- then at most @d@ digits after the decimal point are shown.+showFFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS -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 ]+-- | Show a signed 'RealFloat' value+-- using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise.+--+-- In the call @'showGFloat' digs val@, if @digs@ is 'Nothing',+-- the value is shown to full precision; if @digs@ is @'Just' d@,+-- then at most @d@ digits after the decimal point are shown.+showGFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS -                 lexFrac ('.':ds) = lexDigits ds-                 lexFrac s        = [("",s)]+showEFloat d x =  showString (formatRealFloat FFExponent d x)+showFFloat d x =  showString (formatRealFloat FFFixed d x)+showGFloat d x =  showString (formatRealFloat FFGeneric d x)+#endif  /* __GLASGOW_HASKELL__ */ -                 readExp (e:s) | e `elem` "eE" = readExp' s-                 readExp s                     = [(0,s)]+-- ---------------------------------------------------------------------------+-- Integer printing functions -                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]-                 readExp' ('+':s) = readDec s-                 readExp' s       = readDec s+-- | Shows a /non-negative/ 'Integral' number using the base specified by the+-- first argument, and the character representation specified by the second.+showIntAtBase :: Integral a => a -> (Int -> Char) -> a -> ShowS+showIntAtBase base toChr n0 r0+  | base <= 1 = error ("Numeric.showIntAtBase: applied to unsupported base " ++ show base)+  | n0 <  0   = error ("Numeric.showIntAtBase: applied to negative number " ++ show n0)+  | otherwise = showIt (quotRem n0 base) r0+   where+    showIt (n,d) r = seq c $ -- stricter than necessary+      case n of+        0 -> r'+        _ -> showIt (quotRem n base) r'+     where+      c  = toChr (fromIntegral d)+      r' = c : r +-- | Show /non-negative/ 'Integral' numbers in base 16.+showHex :: Integral a => a -> ShowS+showHex = showIntAtBase 16 intToDigit +-- | Show /non-negative/ 'Integral' numbers in base 8.+showOct :: Integral a => a -> ShowS+showOct = showIntAtBase 8  intToDigit
lib/base/src/Prelude.hs view
@@ -1,416 +1,215 @@-{-# OPTIONS_LHC -funboxed-tuples #-}-module Prelude(-    -- export everything here-    module Prelude,-    -- export types from elsewhere-    IO(),-    IOError(),-    Rational(),-    -- functions from elsewhere-    putStr,-    putStrLn,-    error,-    concatMap,-    concat,-    any,-    all,-    subtract,-    even,-    odd,-    foldr,-    and,-    filter,-    or,-    length,-    null,-    head,-    tail,-    last,-    init,-    takeWhile,-    dropWhile,-    span,-    break,-    (!!),-    Maybe(Just,Nothing),-    maybe,-    sequence,-    sequence_,-    -- submodules-    module Lhc.Basics,-    module Lhc.Float,-    module Lhc.Enum,-    module Lhc.Order,-    module Lhc.Show,-    Num(..),-    fromIntegral,-    elem,notElem,-    realToFrac,-    Real(..),-    Integral(..),-    Fractional(..),-    Floating(..),-    RealFrac(properFraction,truncate,round,ceiling,floor),-    RealFloat(..),-    module Lhc.Monad,-    Int(),--    module Prelude.IO,-    module Prelude.Text-    ) where---import Lhc.Basics-import Lhc.Float-import Data.Int(Int())--import Lhc.Inst.Enum-import Lhc.Inst.Read-import Lhc.Inst.Show-import Lhc.Inst.Storable--import Data.Ratio-import Lhc.Enum-import Lhc.IO-import Lhc.List-import Lhc.Monad-import Lhc.Num-import Lhc.Order-import Lhc.Show-import Lhc.Maybe-import Lhc.Tuples-import Prelude.Float-import Prelude.IO-import Prelude.IOError-import Prelude.Text-import qualified Data.Char as Char(isSpace,ord,chr)------ 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`------ Numeric functions-----{-# 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)-                                          | otherwise = 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))----------data Either a b = Left a | Right b-    deriving (Eq, Ord, Read, Show)--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, ...]-----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 _ []      =  []---- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the--- above functions.-----foldr :: (a -> b -> b) -> b -> [a] -> b---foldr k z [] = z---foldr k z (x:xs) = k x (foldr k z xs)---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----- 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 <= 0 = []-    f n = let n' = n - 1 in n' `seq` (x:f n')---- 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'---- 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 <= 0 =  []-    f _ []              =  []-    f n (x:xs)          =  x : f (n-1) xs---drop :: Int -> [a] -> [a]-drop n xs = f n xs where-    f n xs | n <= 0 =  xs-    f _ [] = []-    f n (_:xs) = f (n-1) xs----splitAt                  :: Int -> [a] -> ([a],[a])---splitAt n xs             =  (take n xs, drop n xs)-splitAt n ls | n < 0	= ([], ls)-splitAt n ls = splitAt' n ls where-    splitAt' :: Int -> [a] -> ([a], [a])-    splitAt' 0  xs  = ([], xs)-    splitAt' _  []  = ([], [])-    splitAt' m (x:xs) = case splitAt' (m - 1) xs of-        (xs', xs'') -> (x: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")-+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Prelude+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Prelude: a standard module imported by default into all Haskell+-- modules.  For more documentation, see the Haskell 98 Report+-- <http://www.haskell.org/onlinereport/>.+--+----------------------------------------------------------------------------- -unwords          :: [String] -> String-unwords []		=  ""-unwords [w]		= w-unwords (w:ws)		= w ++ ' ' : unwords ws+module Prelude ( +    -- * Standard types, classes and related functions --- lookup key assocs looks up a key in an association list.+    -- ** Basic data types+    Bool(False, True),+    (&&), (||), not, otherwise, -{- SPECIALIZE lookup :: forall b . Char -> (Char,b) -> Maybe b #-}-{- SPECIALIZE lookup :: forall b . Int -> (Int,b) -> Maybe b #-}+    Maybe(Nothing, Just),+    maybe, -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+    Either(Left, Right),+    either, --- sum and product compute the sum or product of a finite list of numbers.+    Ordering(LT, EQ, GT),+    Char, String, -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)+    -- *** Tuples+    fst, snd, curry, uncurry, --- maximum and minimum return the maximum or minimum value from a list,--- which must be non-empty, finite, and of an ordered type.+#if defined(__NHC__)+    []((:), []),        -- Not legal Haskell 98;+                        -- ... available through built-in syntax+    module Data.Tuple,  -- Includes tuple types+    ()(..),             -- Not legal Haskell 98+    (->),               -- ... available through built-in syntax+#endif+#ifdef __HUGS__+    (:),                -- Not legal Haskell 98+#endif -maximum, minimum :: (Ord a) => [a] -> a-maximum []       =  error "Prelude.maximum: empty list"-maximum xs       =  foldl1 max xs+    -- ** Basic type classes+    Eq((==), (/=)),+    Ord(compare, (<), (<=), (>=), (>), max, min),+    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,+         enumFromTo, enumFromThenTo),+    Bounded(minBound, maxBound), -minimum []       =  error "Prelude.minimum: empty list"-minimum xs       =  foldl1 min xs+    -- ** Numbers +    -- *** Numeric types+    Int, Integer, Float, Double,+    Rational, -zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]-zip3             =  zipWith3 (\a b c -> (a,b,c))+    -- *** Numeric type classes+    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), +    -- *** Numeric functions+    subtract, even, odd, gcd, lcm, (^), (^^),+    fromIntegral, realToFrac, +    -- ** Monads and functors+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<), -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 _ _ _ _ =  []+    -- ** Miscellaneous functions+    id, const, (.), flip, ($), until,+    asTypeOf, error, undefined,+    seq, ($!), +    -- * List operations+    map, (++), filter,+    head, last, tail, init, null, length, (!!),+    reverse,+    -- ** Reducing lists (folds)+    foldl, foldl1, foldr, foldr1,+    -- *** Special folds+    and, or, any, all,+    sum, product,+    concat, concatMap,+    maximum, minimum,+    -- ** Building lists+    -- *** Scans+    scanl, scanl1, scanr, scanr1,+    -- *** Infinite lists+    iterate, repeat, replicate, cycle,+    -- ** Sublists+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    -- ** Searching lists+    elem, notElem, lookup,+    -- ** Zipping and unzipping lists+    zip, zip3, zipWith, zipWith3, unzip, unzip3,+    -- ** Functions on strings+    lines, words, unlines, unwords, --- unzip transforms a list of pairs into a pair of lists.+    -- * Converting to and from @String@+    -- ** Converting to @String@+    ShowS,+    Show(showsPrec, showList, show),+    shows,+    showChar, showString, showParen,+    -- ** Converting from @String@+    ReadS,+    Read(readsPrec, readList),+    reads, readParen, read, lex, +    -- * Basic Input and output+    IO,+    -- ** Simple I\/O operations+    -- All I/O functions defined here are character oriented.  The+    -- treatment of the newline character will vary on different systems.+    -- For example, two characters of input, return and linefeed, may+    -- read as a single newline character.  These functions cannot be+    -- used portably for binary I/O.+    -- *** Output functions+    putChar,+    putStr, putStrLn, print,+    -- *** Input functions+    getChar,+    getLine, getContents, interact,+    -- *** Files+    FilePath,+    readFile, writeFile, appendFile, readIO, readLn,+    -- ** Exception handling in the I\/O monad+    IOError, ioError, userError, catch -unzip            :: [(a,b)] -> ([a],[b])-unzip            =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])+  ) where +#ifndef __HUGS__+import Control.Monad+import System.IO+import Data.List+import Data.Either+import Data.Maybe+import Data.Tuple+#endif -unzip3           :: [(a,b,c)] -> ([a],[b],[c])-unzip3           =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))-                          ([],[],[])+#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import Text.Read+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Float+import GHC.Show+import GHC.Err   ( error, undefined )+#endif +#ifndef __HUGS__+import qualified Control.Exception.Base as New (catch)+#endif -instance Real Integer where-    toRational = fromInteger-instance Real Int where-    toRational = fromInt+#ifdef __HUGS__+import Hugs.Prelude+#endif +#ifndef __HUGS__+infixr 0 $! +-- -----------------------------------------------------------------------------+-- Miscellaneous functions -{-# 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 #-}+-- | Strict (call-by-value) application, defined in terms of 'seq'.+($!)    :: (a -> b) -> a -> b+f $! x  = x `seq` f x+#endif -{-# 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   #-}+#ifdef __HADDOCK__+-- | The value of @'seq' a b@ is bottom if @a@ is bottom, and otherwise+-- equal to @b@.  'seq' is usually introduced to improve performance by+-- avoiding unneeded laziness.+seq :: a -> b -> b+seq _ y = y+#endif -default(Int,Double)+#ifndef __HUGS__+-- | The 'catch' function establishes a handler that receives any 'IOError'+-- raised in the action protected by 'catch'.  An 'IOError' is caught by+-- the most recent handler established by 'catch'.  These handlers are+-- not selective: all 'IOError's are caught.  Exception propagation+-- must be explicitly provided in a handler by re-raising any unwanted+-- exceptions.  For example, in+--+-- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e)+--+-- the function @f@ returns @[]@ when an end-of-file exception+-- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the+-- exception is propagated to the next outer handler.+--+-- When an exception propagates outside the main program, the Haskell+-- system prints the associated 'IOError' value and exits the program.+--+-- Non-I\/O exceptions are not caught by this variant; to catch all+-- exceptions, use 'Control.Exception.catch' from "Control.Exception".+catch :: IO a -> (IOError -> IO a) -> IO a+catch = New.catch+#endif /* !__HUGS__ */
+ lib/base/src/Prelude.hs-boot view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module Prelude where++import GHC.IOBase++catch :: IO a -> (IOError -> IO a) -> IO a
− lib/base/src/Prelude/CType.hs 
@@ -1,75 +0,0 @@-{-# OPTIONS_LHC -N #-}-module Prelude.CType (-    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,-    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,-    digitToInt, intToDigit,-    toUpper, toLower-    ) where--import Lhc.Basics-import Lhc.Order-import Lhc.Num-import Data.Word-import Lhc.IO-import Lhc.List---- 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' + 10)-  | c >= 'A' && c <= 'F' =  ord c - (ord 'A' + 10)-  | otherwise            =  error "Char.digitToInt: not a digit"--intToDigit :: Int -> Char-intToDigit i = f (fromIntegral i :: Word) where-    f w | w < 10 = chr (ord '0' + i)-        | w < 16 = chr ((ord 'a' - 10) + i)-        | otherwise = error "Char.intToDigit: not a digit"---- Case-changing operations-toUpper :: Char -> Char-toUpper c | isLower c = chr $ ord c - 32-          | otherwise = c--toLower :: Char -> Char-toLower c | isUpper c = chr $ ord c + 32-          | otherwise = c--elem    :: Char -> [Char] -> 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
− lib/base/src/Prelude/Float.hs 
@@ -1,303 +0,0 @@-{-# OPTIONS_LHC -N -fffi -fm4  #-}--module Prelude.Float(readDouble,doubleToDigits,doubleToRational) where--import Lhc.Order-import Lhc.Basics-import Lhc.Monad-import Lhc.IO-import Lhc.Float-import Lhc.Num-import Lhc.Types-import Data.Word-import Foreign.Storable-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Numeric-import Prelude.Text-import Lhc.List-import Prelude((^),(^^),elem,take)-----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 -> Ptr CInt -> IO $1--}})--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 = unsafePerformIO $ alloca $ \ptr -> do-        x' <- c_frexpf x ptr-        exp <- peek ptr-        return (x', fromIntegral exp)--    encodeFloat i e = c_ldexpf (fromInteger i) (fromInt e)-    decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do-        x' <- c_frexp (floatToDouble x) ptr-        exp <- peek ptr-        let x'' =  c_ldexp x' (fromInt $ floatDigits x)-        return (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 = unsafePerformIO $ alloca $ \ptr -> do-        x' <- c_frexp x ptr-        exp <- peek ptr-        return (x', fromIntegral exp)--    encodeFloat i e = c_ldexp (integer2double i) (fromInt e)-    decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do-        x' <- c_frexp x ptr-        exp <- peek ptr-        let x'' = c_ldexp x' (fromInt $ floatDigits x)-        return (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/base/src/Prelude/IO.hs 
@@ -1,131 +0,0 @@-{-# OPTIONS_LHC -N -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 Foreign.C.Types-import Foreign.Ptr-import Lhc.Addr-import Lhc.Basics-import Lhc.IO-import Lhc.Monad-import Lhc.Order-import Lhc.Show-import Prelude.IOError----- 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 (ptrFromAddr__ "r"#)-    if  (file == nullPtr) then (fail "Could not open file.") 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---foreign import ccall "stdio.h fopen" c_fopen :: CString -> CString -> IO (Ptr ())-foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt-foreign import ccall "wchar.h lhc_utf8_getc" c_fgetwc :: Ptr () -> IO Int---- | 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 -> IO ()-writeFile  =  error "writeFile"--appendFile :: FilePath -> String -> IO ()-appendFile =  error "appendFile"----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--foreign import ccall "stdio.h lhc_utf8_putchar" c_putwchar :: Int -> IO ()-foreign import ccall "wchar.h lhc_utf8_getchar" c_getwchar :: IO Int--
− lib/base/src/Prelude/IOError.hs 
@@ -1,62 +0,0 @@-{-# OPTIONS_LHC -N #-}-module Prelude.IOError(IOError(),showIOError,userError) where--import Lhc.IO-import Lhc.Show--instance Show IOError where-    showsPrec _ s = showString (showIOError s)--{---data IOError = IOError {-     ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging-				     -- the error.-     ioe_type     :: IOErrorType,    -- what it was.-     ioe_location :: String,	     -- location.-     ioe_description :: String,      -- error type specific information.-     ioe_filename :: Maybe FilePath  -- filename the error is related to.-   } deriving(Eq)----- | An abstract type that contains a value for each variant of 'IOError'.-data IOErrorType-  = AlreadyExists-  | NoSuchThing-  | ResourceBusy-  | ResourceExhausted-  | EOF-  | IllegalOperation-  | PermissionDenied-  | UserError--instance Show IOErrorType where-  showsPrec _ e =-    showString $-    case e of-      AlreadyExists	-> "already exists"-      NoSuchThing       -> "does not exist"-      ResourceBusy      -> "resource busy"-      ResourceExhausted -> "resource exhausted"-      EOF		-> "end of file"-      IllegalOperation	-> "illegal operation"-      PermissionDenied  -> "permission denied"-      UserError		-> "user error"--instance Show IOException where-    showsPrec p (IOError hdl iot loc s fn) =-      (case fn of-	 Nothing -> case hdl of-		        Nothing -> id-			Just h  -> showsPrec p h . showString ": "-	 Just name -> showString name . showString ": ") .-      (case loc of-         "" -> id-	 _  -> showString loc . showString ": ") .-      showsPrec p iot .-      (case s of-	 "" -> id-	 _  -> showString " (" . showString s . showString ")")---}-
− lib/base/src/Prelude/Text.hs 
@@ -1,123 +0,0 @@-module Prelude.Text (-    ReadS, ShowS,-    Read(readsPrec, readList),-    Show(showsPrec, show, showList),-    reads, shows, read, lex,-    showChar, showString, readParen, showParen,readIO,readLn ) where---- The instances of Read and Show for---      Bool, Maybe, Either, Ordering--- are done via "deriving" clauses in Prelude.hs-import Lhc.Show-import Lhc.Inst.Show()-import Prelude.Float-import Lhc.Basics-import Lhc.Monad-import Lhc.IO-import Prelude.IO-import Lhc.Order-import Lhc.Maybe-import Lhc.Text.Read---import Data.Char(isSpace, isAlpha, isDigit, isAlphaNum,-                 showLitChar, readLitChar, lexLitChar)--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-
− lib/base/src/System.hs 
@@ -1,84 +0,0 @@-{-# OPTIONS_LHC -fffi #-}-module System (-    ExitCode(ExitSuccess,ExitFailure),-    getArgs, getProgName, getEnv, system, exitWith, exitFailure-  ) where--import Foreign.C.String-import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Alloc-import Foreign.C.Types-import Lhc.IO(exitFailure)-import qualified Lhc.Options--data ExitCode = ExitSuccess | ExitFailure !Int-            deriving (Eq, Ord, Read, Show)--getArgs     :: IO [String]-getProgName :: IO String-getEnv      :: String -> IO String-system      :: String -> IO ExitCode-exitWith    :: ExitCode -> IO a-exitFailure :: IO a---exitWith ExitSuccess = do-    c_exit 0-    return undefined-exitWith (ExitFailure n) = do-    c_exit n-    return undefined---getProgName = case Lhc.Options.target of---    Lhc.Options.GhcHs -> ghc_getProgName-    _ -> peek lhc_progname >>= peekCString--getArgs = case Lhc.Options.target of---    Lhc.Options.GhcHs -> ghc_getArgs-    _ -> do -        argc <- peek lhc_argc-        argv <- peek lhc_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---system s = withCString s c_system >>= \r -> case r of-    0 -> return ExitSuccess-    _ -> return $ ExitFailure (fromIntegral r)--foreign import unsafe ccall "exit" c_exit :: Int -> IO ()-foreign import unsafe ccall "system" c_system :: CString -> IO CInt-foreign import unsafe ccall "stdlib.h getenv" c_getenv :: Ptr CChar -> IO (Ptr CChar)--foreign import ccall "&lhc_progname" lhc_progname :: Ptr CString-foreign import ccall "&lhc_argc" lhc_argc :: Ptr CInt-foreign import ccall "&lhc_argv" lhc_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--}
− lib/base/src/System/CPUTime.hs 
@@ -1,3 +0,0 @@--- | Skeleton only, fixme.-module System.CPUTime where-
− lib/base/src/System/Console/GetOpt.hs 
@@ -1,303 +0,0 @@--------------------------------------------------------------------------------- |--- 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 Prelude -- necessary to get dependencies right--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/base/src/System/Directory.hs 
@@ -1,40 +0,0 @@-module System.Directory where-{-- (-    Permissions( Permissions, readable, writable, executable, searchable ),-    createDirectory, removeDirectory, removeFile,-    renameDirectory, renameFile, getDirectoryContents,-    getCurrentDirectory, setCurrentDirectory,-    doesFileExist, doesDirectoryExist,-    getPermissions, setPermissions,-    getModificationTime ) where--import Time ( ClockTime )--data Permissions = Permissions {-    readable,   writable,-    executable, searchable :: Bool-   } deriving (Eq,Ord,Read,Show)-----createDirectory  :: FilePath -> IO ()-removeDirectory  :: FilePath -> IO ()-removeFile  :: FilePath -> IO ()-renameDirectory  :: FilePath -> FilePath -> IO ()-renameFile  :: FilePath -> FilePath -> IO ()--getDirectoryContents  :: FilePath -> IO [FilePath]-getCurrentDirectory  :: IO FilePath-setCurrentDirectory  :: FilePath -> IO ()--doesFileExist :: FilePath -> IO Bool-doesDirectoryExist :: FilePath -> IO Bool--getPermissions :: FilePath -> IO Permissions-setPermissions :: FilePath -> Permissions -> IO ()--getModificationTime :: FilePath -> IO ClockTime---}
+ lib/base/src/System/Environment.hs view
@@ -0,0 +1,196 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Environment+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Miscellaneous information about the system environment.+--+-----------------------------------------------------------------------------++module System.Environment+    (+      getArgs,       -- :: IO [String]+      getProgName,   -- :: IO String+      getEnv,        -- :: String -> IO String+#ifndef __NHC__+      withArgs,+      withProgName,+#endif+#ifdef __GLASGOW_HASKELL__+      getEnvironment,+#endif+  ) where++import Prelude++#ifdef __GLASGOW_HASKELL__+import Data.List+import Foreign+import Foreign.C+import Control.Exception.Base   ( bracket )+import Control.Monad+import GHC.IOBase+#endif++#ifdef __HUGS__+import Hugs.System+#endif++#ifdef __NHC__+import System+  ( getArgs+  , getProgName+  , getEnv+  )+#endif++-- ---------------------------------------------------------------------------+-- getArgs, getProgName, getEnv++-- | Computation 'getArgs' returns a list of the program's command+-- line arguments (not including the program name).++#ifdef __GLASGOW_HASKELL__+getArgs :: IO [String]+getArgs =+  alloca $ \ p_argc ->+  alloca $ \ p_argv -> do+   getProgArgv p_argc p_argv+   p    <- fromIntegral `liftM` peek p_argc+   argv <- peek p_argv+   peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString+++foreign import ccall unsafe "getProgArgv"+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++{-|+Computation 'getProgName' returns the name of the program as it was+invoked.++However, this is hard-to-impossible to implement on some non-Unix+OSes, so instead, for maximum portability, we just return the leafname+of the program as invoked. Even then there are some differences+between platforms: on Windows, for example, a program invoked as foo+is probably really @FOO.EXE@, and that is what 'getProgName' will return.+-}+getProgName :: IO String+getProgName =+  alloca $ \ p_argc ->+  alloca $ \ p_argv -> do+     getProgArgv p_argc p_argv+     argv <- peek p_argv+     unpackProgName argv++unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]+unpackProgName argv = do+  s <- peekElemOff argv 0 >>= peekCString+  return (basename s)+  where+   basename :: String -> String+   basename f = go f f+    where+      go acc [] = acc+      go acc (x:xs)+        | isPathSeparator x = go xs xs+        | otherwise         = go acc xs++   isPathSeparator :: Char -> Bool+   isPathSeparator '/'  = True+#ifdef mingw32_HOST_OS +   isPathSeparator '\\' = True+#endif+   isPathSeparator _    = False+++-- | Computation 'getEnv' @var@ returns the value+-- of the environment variable @var@.  +--+-- This computation may fail with:+--+--  * 'System.IO.Error.isDoesNotExistError' if the environment variable+--    does not exist.++getEnv :: String -> IO String+getEnv name =+    withCString name $ \s -> do+      litstring <- c_getenv s+      if litstring /= nullPtr+        then peekCString litstring+        else ioException (IOError Nothing NoSuchThing "getEnv"+                          "no environment variable" (Just name))++foreign import ccall unsafe "getenv"+   c_getenv :: CString -> IO (Ptr CChar)++{-|+'withArgs' @args act@ - while executing action @act@, have 'getArgs'+return @args@.+-}+withArgs :: [String] -> IO a -> IO a+withArgs xs act = do+   p <- System.Environment.getProgName+   withArgv (p:xs) act++{-|+'withProgName' @name act@ - while executing action @act@,+have 'getProgName' return @name@.+-}+withProgName :: String -> IO a -> IO a+withProgName nm act = do+   xs <- System.Environment.getArgs+   withArgv (nm:xs) act++-- Worker routine which marshals and replaces an argv vector for+-- the duration of an action.++withArgv :: [String] -> IO a -> IO a+withArgv new_args act = do+  pName <- System.Environment.getProgName+  existing_args <- System.Environment.getArgs+  bracket (setArgs new_args)+          (\argv -> do setArgs (pName:existing_args); freeArgv argv)+          (const act)++freeArgv :: Ptr CString -> IO ()+freeArgv argv = do+  size <- lengthArray0 nullPtr argv+  sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]+  free argv++setArgs :: [String] -> IO (Ptr CString)+setArgs argv = do+  vs <- mapM newCString argv >>= newArray0 nullPtr+  setArgsPrim (genericLength argv) vs+  return vs++foreign import ccall unsafe "setProgArgv" +  setArgsPrim  :: CInt -> Ptr CString -> IO ()++-- |'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 <- getEnvBlock+   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 unsafe "__hscore_environ" +  getEnvBlock :: IO (Ptr CString)+#endif  /* __GLASGOW_HASKELL__ */
lib/base/src/System/IO.hs view
@@ -1,160 +1,541 @@-{-# OPTIONS_LHC -fffi #-}-module System.IO(-    BufferMode(..),-    Handle,-    IOMode(..),-    SeekMode(..),-    hClose,-    hFileSize,-    hSeek,-    hTell,-    hFlush,-    hGetBuf,-    hGetPosn,-    hSetPosn,-    hGetContents,-    hIsOpen,-    hPrint,-    hPutBuf,-    hPutChar,-    hPutStr,-    hPutStrLn,-    openFile,+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  System.IO+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The standard IO library.+--+-----------------------------------------------------------------------------++module System.IO (+    -- * The IO monad++    IO,                        -- instance MonadFix+    fixIO,                     -- :: (a -> IO a) -> IO a++    -- * Files and handles++    FilePath,                  -- :: String++    Handle,             -- abstract, instance of: Eq, Show.++    -- ** Standard handles++    -- | Three handles are allocated during program initialisation,+    -- and are initially open.++    stdin, stdout, stderr,   -- :: Handle++    -- * Opening and closing files++    -- ** Opening files+     withFile,-    fixIO,-    stdin,stdout,stderr,-    try+    openFile,                  -- :: FilePath -> IOMode -> IO Handle+    IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), -    ) where+    -- ** Closing files -import Lhc.IO-import Lhc.Handle-import Prelude.IOError-import Foreign.Ptr-import Foreign.Storable+    hClose,                    -- :: Handle -> IO ()++    -- ** Special cases++    -- | These functions are also exported by the "Prelude".++    readFile,                  -- :: FilePath -> IO String+    writeFile,                 -- :: FilePath -> String -> IO ()+    appendFile,                -- :: FilePath -> String -> IO ()++    -- ** File locking++    -- $locking++    -- * Operations on handles++    -- ** Determining and changing the size of a file++    hFileSize,                 -- :: Handle -> IO Integer+#ifdef __GLASGOW_HASKELL__+    hSetFileSize,              -- :: Handle -> Integer -> IO ()+#endif++    -- ** Detecting the end of input++    hIsEOF,                    -- :: Handle -> IO Bool+    isEOF,                     -- :: IO Bool++    -- ** Buffering operations++    BufferMode(NoBuffering,LineBuffering,BlockBuffering),+    hSetBuffering,             -- :: Handle -> BufferMode -> IO ()+    hGetBuffering,             -- :: Handle -> IO BufferMode+    hFlush,                    -- :: Handle -> IO ()++    -- ** Repositioning handles++    hGetPosn,                  -- :: Handle -> IO HandlePosn+    hSetPosn,                  -- :: HandlePosn -> IO ()+    HandlePosn,                -- abstract, instance of: Eq, Show.++    hSeek,                     -- :: Handle -> SeekMode -> Integer -> IO ()+    SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),+#if !defined(__NHC__)+    hTell,                     -- :: Handle -> IO Integer+#endif++    -- ** Handle properties++    hIsOpen, hIsClosed,        -- :: Handle -> IO Bool+    hIsReadable, hIsWritable,  -- :: Handle -> IO Bool+    hIsSeekable,               -- :: Handle -> IO Bool++    -- ** Terminal operations (not portable: GHC\/Hugs only)++#if !defined(__NHC__)+    hIsTerminalDevice,          -- :: Handle -> IO Bool++    hSetEcho,                   -- :: Handle -> Bool -> IO ()+    hGetEcho,                   -- :: Handle -> IO Bool+#endif++    -- ** Showing handle state (not portable: GHC only)++#ifdef __GLASGOW_HASKELL__+    hShow,                      -- :: Handle -> IO String+#endif++    -- * Text input and output++    -- ** Text input++    hWaitForInput,             -- :: Handle -> Int -> IO Bool+    hReady,                    -- :: Handle -> IO Bool+    hGetChar,                  -- :: Handle -> IO Char+    hGetLine,                  -- :: Handle -> IO [Char]+    hLookAhead,                -- :: Handle -> IO Char+    hGetContents,              -- :: Handle -> IO [Char]++    -- ** Text output++    hPutChar,                  -- :: Handle -> Char -> IO ()+    hPutStr,                   -- :: Handle -> [Char] -> IO ()+    hPutStrLn,                 -- :: Handle -> [Char] -> IO ()+    hPrint,                    -- :: Show a => Handle -> a -> IO ()++    -- ** Special cases for standard input and output++    -- | These functions are also exported by the "Prelude".++    interact,                  -- :: (String -> String) -> IO ()+    putChar,                   -- :: Char   -> IO ()+    putStr,                    -- :: String -> IO () +    putStrLn,                  -- :: String -> IO ()+    print,                     -- :: Show a => a -> IO ()+    getChar,                   -- :: IO Char+    getLine,                   -- :: IO String+    getContents,               -- :: IO String+    readIO,                    -- :: Read a => String -> IO a+    readLn,                    -- :: Read a => IO a++    -- * Binary input and output++    withBinaryFile,+    openBinaryFile,            -- :: FilePath -> IOMode -> IO Handle+    hSetBinaryMode,            -- :: Handle -> Bool -> IO ()+    hPutBuf,                   -- :: Handle -> Ptr a -> Int -> IO ()+    hGetBuf,                   -- :: Handle -> Ptr a -> Int -> IO Int+#if !defined(__NHC__) && !defined(__HUGS__)+    hPutBufNonBlocking,        -- :: Handle -> Ptr a -> Int -> IO Int+    hGetBufNonBlocking,        -- :: Handle -> Ptr a -> Int -> IO Int+#endif++    -- * Temporary files++    openTempFile,+    openBinaryTempFile,+  ) where++import Control.Exception.Base++#ifndef __NHC__+import Data.Bits+import Data.List+import Data.Maybe+import Foreign.C.Error+import Foreign.C.String import Foreign.C.Types-import Data.Char(ord)-import Data.Int+import System.Posix.Internals+#endif +#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase       -- Together these four Prelude modules define+import GHC.Handle       -- all the stuff exported by IO for the GHC version+import GHC.IO+import GHC.Exception+import GHC.Num+import Text.Read+import GHC.Show+#endif -data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)-    deriving(Eq, Ord, Read, Show)-data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd-    deriving(Eq,Ord,Bounded,Enum,Read,Show)+#ifdef __HUGS__+import Hugs.IO+import Hugs.IOExts+import Hugs.IORef+import System.IO.Unsafe ( unsafeInterleaveIO )+#endif -type HandlePosn = Integer+#ifdef __NHC__+import IO+  ( Handle ()+  , HandlePosn ()+  , IOMode (ReadMode,WriteMode,AppendMode,ReadWriteMode)+  , BufferMode (NoBuffering,LineBuffering,BlockBuffering)+  , SeekMode (AbsoluteSeek,RelativeSeek,SeekFromEnd)+  , stdin, stdout, stderr+  , openFile                  -- :: FilePath -> IOMode -> IO Handle+  , hClose                    -- :: Handle -> IO ()+  , hFileSize                 -- :: Handle -> IO Integer+  , hIsEOF                    -- :: Handle -> IO Bool+  , isEOF                     -- :: IO Bool+  , hSetBuffering             -- :: Handle -> BufferMode -> IO ()+  , hGetBuffering             -- :: Handle -> IO BufferMode+  , hFlush                    -- :: Handle -> IO ()+  , hGetPosn                  -- :: Handle -> IO HandlePosn+  , hSetPosn                  -- :: HandlePosn -> IO ()+  , hSeek                     -- :: Handle -> SeekMode -> Integer -> IO ()+  , hWaitForInput             -- :: Handle -> Int -> IO Bool+  , hGetChar                  -- :: Handle -> IO Char+  , hGetLine                  -- :: Handle -> IO [Char]+  , hLookAhead                -- :: Handle -> IO Char+  , hGetContents              -- :: Handle -> IO [Char]+  , hPutChar                  -- :: Handle -> Char -> IO ()+  , hPutStr                   -- :: Handle -> [Char] -> IO ()+  , hPutStrLn                 -- :: Handle -> [Char] -> IO ()+  , hPrint                    -- :: Handle -> [Char] -> IO ()+  , hReady                    -- :: Handle -> [Char] -> IO ()+  , hIsOpen, hIsClosed        -- :: Handle -> IO Bool+  , hIsReadable, hIsWritable  -- :: Handle -> IO Bool+  , hIsSeekable               -- :: Handle -> IO Bool+  , bracket +  , IO ()+  , FilePath                  -- :: String+  )+import NHC.IOExtras (fixIO, hPutBuf, hGetBuf)+import NHC.FFI (Ptr)+#endif +-- -----------------------------------------------------------------------------+-- Standard IO -try            :: IO a -> IO (Either IOError a)-try f          =  catch (do r <- f-                            return (Right r))-                        (return . Left)+#ifdef __GLASGOW_HASKELL__+-- | Write a character to the standard output device+-- (same as 'hPutChar' 'stdout'). +putChar         :: Char -> IO ()+putChar c       =  hPutChar stdout c -withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFile fp iom action = do-    h <- openFile fp iom-    r <- action h-    hClose h-    return r+-- | Write a string to the standard output device+-- (same as 'hPutStr' 'stdout'). +putStr          :: String -> IO ()+putStr s        =  hPutStr stdout s +-- | The same as 'putStr', but adds a newline character. -hFlush :: Handle -> IO ()-hFlush h = withHandle h c_fflush+putStrLn        :: String -> IO ()+putStrLn s      =  do putStr s+                      putChar '\n' -isEOF :: IO Bool-isEOF = hIsEOF stdin+-- | The 'print' function outputs a value of any printable type to the+-- standard output device.+-- Printable types are those that are instances of class 'Show'; 'print'+-- converts values to strings for output using the 'show' operation and+-- adds a newline.+--+-- For example, a program to print the first 20 integers and their+-- powers of 2 could be written as:+--+-- > main = print ([(n, 2^n) | n <- [0..19]]) -hIsEOF :: Handle -> IO Bool-hIsEOF h = withHandle h $ \ptr -> do-    r <- c_feof ptr-    return (r /= 0)+print           :: Show a => a -> IO ()+print x         =  putStrLn (show x) -hPutChar h ch = withHandle h $ \ptr -> do-    c_fputwc (fromInt (ord ch)) ptr-    return ()+-- | Read a character from the standard input device+-- (same as 'hGetChar' 'stdin'). -hPutStr     :: Handle -> String -> IO ()-hPutStr h s   = withHandle h $ \ptr -> do-    sequence_ [ c_fputwc (fromInt (ord ch)) ptr | ch <- s ]+getChar         :: IO Char+getChar         =  hGetChar stdin -hPutStrLn   :: Handle -> String -> IO ()-hPutStrLn h s = do-    hPutStr h s-    hPutChar h '\n'+-- | Read a line from the standard input device+-- (same as 'hGetLine' 'stdin'). -hPrint      :: Show a => Handle -> a -> IO ()-hPrint h x    =  hPutStrLn h (show x)+getLine         :: IO String+getLine         =  hGetLine stdin +-- | The 'getContents' operation returns all user input as a single string,+-- which is read lazily as it is needed+-- (same as 'hGetContents' 'stdin'). -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'+getContents     :: IO String+getContents     =  hGetContents stdin -hTell :: Handle -> IO Integer-hTell h = withHandle h $ \ptr -> fmap fromIntegral (c_ftell ptr)+-- | 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. -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 ()+interact        ::  (String -> String) -> IO ()+interact f      =   do s <- getContents+                       putStr (f s) -hGetPosn :: Handle -> IO HandlePosn-hGetPosn h = hTell h+-- | The 'readFile' function reads a file and+-- returns the contents of the file as a string.+-- The file is read lazily, on demand, as with 'getContents'. -hSetPosn :: Handle -> HandlePosn -> IO ()-hSetPosn h hp = hSeek h AbsoluteSeek hp+readFile        :: FilePath -> IO String+readFile name   =  openFile name ReadMode >>= hGetContents -hPutBuf :: Handle -> Ptr a -> Int -> IO ()-hPutBuf h p c = do-    let count = fromIntegral c-    rc <- withHandle h $ fwrite p 1 count-    if rc /= count then fail "hPutBuf: short write" else return ()+-- | The computation 'writeFile' @file str@ function writes the string @str@,+-- to the file @file@.+writeFile :: FilePath -> String -> IO ()+writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt) -hGetBuf :: Handle -> Ptr a -> Int -> IO Int-hGetBuf h p c = do-    let count = fromIntegral c-    rc <- withHandle h $ fread p 1 count-    return $ fromIntegral rc+-- | The computation 'appendFile' @file str@ function appends the string @str@,+-- to the file @file@.+--+-- Note that 'writeFile' and 'appendFile' write a literal string+-- to a file.  To write a value of any printable type, as with 'print',+-- use the 'show' function to convert the value to a string first.+--+-- > main = appendFile "squares" (show [(x,x*x) | x <- [0,0.1..2]]) -hFileSize :: Handle -> IO Integer-hFileSize h = do-    cp <- hTell h-    hSeek h SeekFromEnd 0-    fl <- hTell h-    hSeek h AbsoluteSeek cp-    return fl+appendFile      :: FilePath -> String -> IO ()+appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt) -foreign import ccall "stdio.h fwrite_unlocked" fwrite  :: Ptr a -> CSize -> CSize -> Ptr Handle -> IO CSize-foreign import ccall "stdio.h fread_unlocked" fread :: Ptr a -> CSize -> CSize -> Ptr Handle -> IO CSize+-- | The 'readLn' function combines 'getLine' and 'readIO'. -foreign import primitive "I2I" cwintToChar :: CWint -> Char+readLn          :: Read a => IO a+readLn          =  do l <- getLine+                      r <- readIO l+                      return r -foreign import ccall "stdio.h fflush" c_fflush :: Ptr Handle -> IO ()+-- | The 'readIO' function is similar to 'read' except that it signals+-- parse failure to the 'IO' monad instead of terminating the program. -foreign import ccall "wchar.h lhc_utf8_getc" c_fgetwc :: Ptr Handle -> IO Int-foreign import ccall "wchar.h lhc_utf8_putc" c_fputwc :: Int -> Ptr Handle -> IO Int+readIO          :: Read a => String -> IO a+readIO s        =  case (do { (x,t) <- reads s ;+                              ("","") <- lex t ;+                              return x }) of+                        [x]    -> return x+                        []     -> ioError (userError "Prelude.readIO: no parse")+                        _      -> ioError (userError "Prelude.readIO: ambiguous parse")+#endif  /* __GLASGOW_HASKELL__ */ -foreign import ccall "stdio.h feof" c_feof :: Ptr Handle -> IO CInt-foreign import ccall "stdio.h ftell" c_ftell :: Ptr Handle -> IO Int                  -- XXX---foreign import ccall "stdio.h ftell" c_ftell :: Ptr Handle -> IO IntMax                  -- XXX-foreign import ccall "stdio.h fseek" c_fseek :: Ptr Handle -> Int -> CInt -> IO CInt  -- XXX---foreign import ccall "stdio.h fseek" c_fseek :: Ptr Handle -> IntMax -> CInt -> IO CInt  -- XXX+#ifndef __NHC__+-- | Computation 'hReady' @hdl@ indicates whether at least one item is+-- available for input from handle @hdl@.+-- +-- This operation may fail with:+--+--  * 'System.IO.Error.isEOFError' if the end of file has been reached. -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+hReady          :: Handle -> IO Bool+hReady h        =  hWaitForInput h 0 +-- | The same as 'hPutStr', but adds a newline character.++hPutStrLn       :: Handle -> String -> IO ()+hPutStrLn hndl str = do+ hPutStr  hndl str+ hPutChar hndl '\n'++-- | Computation 'hPrint' @hdl t@ writes the string representation of @t@+-- given by the 'shows' function to the file or channel managed by @hdl@+-- and appends a newline.+--+-- This operation may fail with:+--+--  * 'System.IO.Error.isFullError' if the device is full; or+--+--  * 'System.IO.Error.isPermissionError' if another system resource limit would be exceeded.++hPrint          :: Show a => Handle -> a -> IO ()+hPrint hdl      =  hPutStrLn hdl . show+#endif /* !__NHC__ */++-- | @'withFile' name mode act@ opens a file using 'openFile' and passes+-- the resulting handle to the computation @act@.  The handle will be+-- closed on exit from 'withFile', whether by normal termination or by+-- raising an exception.+withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFile name mode = bracket (openFile name mode) hClose++-- | @'withBinaryFile' name mode act@ opens a file using 'openBinaryFile'+-- and passes the resulting handle to the computation @act@.  The handle+-- will be closed on exit from 'withBinaryFile', whether by normal+-- termination or by raising an exception.+withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withBinaryFile name mode = bracket (openBinaryFile name mode) hClose++-- ---------------------------------------------------------------------------+-- fixIO++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+fixIO :: (a -> IO a) -> IO a+fixIO k = do+    ref <- newIORef (throw NonTermination)+    ans <- unsafeInterleaveIO (readIORef ref)+    result <- k ans+    writeIORef ref result+    return result++-- NOTE: we do our own explicit black holing here, because GHC's lazy+-- blackholing isn't enough.  In an infinite loop, GHC may run the IO+-- computation a few times before it notices the loop, which is wrong.+#endif++#if defined(__NHC__)+-- Assume a unix platform, where text and binary I/O are identical.+openBinaryFile = openFile+hSetBinaryMode _ _ = return ()+#endif++-- | The function creates a temporary file in ReadWrite mode.+-- The created file isn\'t deleted automatically, so you need to delete it manually.+--+-- The file is creates with permissions such that only the current+-- user can read\/write it.+--+-- With some exceptions (see below), the file will be created securely+-- in the sense that an attacker should not be able to cause+-- openTempFile to overwrite another file on the filesystem using your+-- credentials, by putting symbolic links (on Unix) in the place where+-- the temporary file is to be created.  On Unix the @O_CREAT@ and+-- @O_EXCL@ flags are used to prevent this attack, but note that+-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you+-- rely on this behaviour it is best to use local filesystems only.+--+openTempFile :: FilePath   -- ^ Directory in which to create the file+             -> String     -- ^ File name template. If the template is \"foo.ext\" then+                           -- the created file will be \"fooXXX.ext\" where XXX is some+                           -- random number.+             -> IO (FilePath, Handle)+openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False++-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)+openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True++openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)+openTempFile' loc tmp_dir template binary = do+  pid <- c_getpid+  findTempName pid+  where+    -- We split off the last extension, so we can use .foo.ext files+    -- for temporary files (hidden on Unix OSes). Unfortunately we're+    -- below filepath in the hierarchy here.+    (prefix,suffix) =+       case break (== '.') $ reverse template of+         -- First case: template contains no '.'s. Just re-reverse it.+         (rev_suffix, "")       -> (reverse rev_suffix, "")+         -- Second case: template contains at least one '.'. Strip the+         -- dot from the prefix and prepend it to the suffix (if we don't+         -- do this, the unique number will get added after the '.' and+         -- thus be part of the extension, which is wrong.)+         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)+         -- Otherwise, something is wrong, because (break (== '.')) should+         -- always return a pair with either the empty string or a string+         -- beginning with '.' as the second component.+         _                      -> error "bug in System.IO.openTempFile"++#ifndef __NHC__+    oflags1 = rw_flags .|. o_EXCL++    binary_flags+      | binary    = o_BINARY+      | otherwise = 0++    oflags = oflags1 .|. binary_flags+#endif++#ifdef __NHC__+    findTempName x = do h <- openFile filepath ReadWriteMode+                        return (filepath, h)+#else+    findTempName x = do+      fd <- withCString filepath $ \ f ->+              c_open f oflags 0o600+      if fd < 0+       then do+         errno <- getErrno+         if errno == eEXIST+           then findTempName (x+1)+           else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))+       else do+         -- XXX We want to tell fdToHandle what the filepath is,+         -- as any exceptions etc will only be able to report the+         -- fd currently+         h <- fdToHandle fd `onException` c_close fd+         return (filepath, h)+#endif+      where+        filename        = prefix ++ show x ++ suffix+        filepath        = tmp_dir `combine` filename++        -- XXX bits copied from System.FilePath, since that's not available here+        combine a b+                  | null b = a+                  | null a = b+                  | last a == pathSeparator = a ++ b+                  | otherwise = a ++ [pathSeparator] ++ b++#if __HUGS__+        fdToHandle fd   = openFd (fromIntegral fd) False ReadWriteMode binary+#endif++-- XXX Should use filepath library+pathSeparator :: Char+#ifdef mingw32_HOST_OS+pathSeparator = '\\'+#else+pathSeparator = '/'+#endif++#ifndef __NHC__+-- XXX Copied from GHC.Handle+std_flags, output_flags, rw_flags :: CInt+std_flags    = o_NONBLOCK   .|. o_NOCTTY+output_flags = std_flags    .|. o_CREAT+rw_flags     = output_flags .|. o_RDWR+#endif++#ifdef __NHC__+foreign import ccall "getpid" c_getpid :: IO Int+#endif++-- $locking+-- Implementations should enforce as far as possible, at least locally to the+-- Haskell process, multiple-reader single-writer locking on files.+-- That is, /there may either be many handles on the same file which manage+-- input, or just one handle on the file which manages output/.  If any+-- open or semi-closed handle is managing a file for output, no new+-- handle can be allocated for that file.  If any open or semi-closed+-- handle is managing a file for input, new handles can only be allocated+-- if they do not manage output.  Whether two files are the same is+-- implementation-dependent, but they should normally be the same if they+-- have the same absolute path name and neither has been renamed, for+-- example.+--+-- /Warning/: the 'readFile' operation holds a semi-closed handle on+-- the file until the entire contents of the file have been consumed.+-- It follows that an attempt to write to a file (using 'writeFile', for+-- example) that was earlier opened by 'readFile' will usually result in+-- failure with 'System.IO.Error.isAlreadyInUseError'.
− lib/base/src/System/IO/Binary.hs 
@@ -1,47 +0,0 @@-{-# OPTIONS_LHC -fffi #-}-module System.IO.Binary(readBinaryFile,putWord8,getWord8) where--import Data.Word-import Lhc.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 read_str-    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 -> CString -> 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/base/src/System/IO/Continuation.hs 
@@ -1,19 +0,0 @@-module System.IO.Continuation(IOCont(),newContinuation,callContinuation) where--import Lhc.JumpPoint-import Lhc.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/base/src/System/IO/Error.hs view
@@ -1,1 +1,390 @@-module System.IO.Error where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.IO.Error+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Standard IO Errors.+--+-----------------------------------------------------------------------------++module System.IO.Error (++    -- * I\/O errors+    IOError,                    -- = IOException++    userError,                  -- :: String  -> IOError++#ifndef __NHC__+    mkIOError,                  -- :: IOErrorType -> String -> Maybe Handle+                                --    -> Maybe FilePath -> IOError++    annotateIOError,            -- :: IOError -> String -> Maybe Handle+                                --    -> Maybe FilePath -> IOError+#endif++    -- ** Classifying I\/O errors+    isAlreadyExistsError,       -- :: IOError -> Bool+    isDoesNotExistError,+    isAlreadyInUseError,+    isFullError, +    isEOFError,+    isIllegalOperation, +    isPermissionError,+    isUserError,++    -- ** Attributes of I\/O errors+#ifndef __NHC__+    ioeGetErrorType,            -- :: IOError -> IOErrorType+    ioeGetLocation,             -- :: IOError -> String+#endif+    ioeGetErrorString,          -- :: IOError -> String+    ioeGetHandle,               -- :: IOError -> Maybe Handle+    ioeGetFileName,             -- :: IOError -> Maybe FilePath++#ifndef __NHC__+    ioeSetErrorType,            -- :: IOError -> IOErrorType -> IOError+    ioeSetErrorString,          -- :: IOError -> String -> IOError+    ioeSetLocation,             -- :: IOError -> String -> IOError+    ioeSetHandle,               -- :: IOError -> Handle -> IOError+    ioeSetFileName,             -- :: IOError -> FilePath -> IOError+#endif++    -- * Types of I\/O error+    IOErrorType,                -- abstract++    alreadyExistsErrorType,     -- :: IOErrorType+    doesNotExistErrorType,+    alreadyInUseErrorType,+    fullErrorType,+    eofErrorType,+    illegalOperationErrorType, +    permissionErrorType,+    userErrorType,++    -- ** 'IOErrorType' predicates+    isAlreadyExistsErrorType,   -- :: IOErrorType -> Bool+    isDoesNotExistErrorType,+    isAlreadyInUseErrorType,+    isFullErrorType, +    isEOFErrorType,+    isIllegalOperationErrorType, +    isPermissionErrorType,+    isUserErrorType, ++    -- * Throwing and catching I\/O errors++    ioError,                    -- :: IOError -> IO a++    catch,                      -- :: IO a -> (IOError -> IO a) -> IO a+    try,                        -- :: IO a -> IO (Either IOError a)++#ifndef __NHC__+    modifyIOError,              -- :: (IOError -> IOError) -> IO a -> IO a+#endif+  ) where++#ifndef __HUGS__+import Data.Either+#endif+import Data.Maybe++#ifdef __GLASGOW_HASKELL__+import {-# SOURCE #-} Prelude (catch)+import qualified Control.Exception.Base as New++import GHC.Base+import GHC.IOBase+import Text.Show+#endif++#ifdef __HUGS__+import Hugs.Prelude(Handle, IOException(..), IOErrorType(..), IO)+#endif++#ifdef __NHC__+import IO+  ( IOError ()+  , try+  , ioError+  , userError+  , isAlreadyExistsError        -- :: IOError -> Bool+  , isDoesNotExistError+  , isAlreadyInUseError+  , isFullError+  , isEOFError+  , isIllegalOperation+  , isPermissionError+  , isUserError+  , ioeGetErrorString           -- :: IOError -> String+  , ioeGetHandle                -- :: IOError -> Maybe Handle+  , ioeGetFileName              -- :: IOError -> Maybe FilePath+  )+--import Data.Maybe (fromJust)+--import Control.Monad (MonadPlus(mplus))+#endif++-- | 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".++#ifndef __NHC__+try            :: IO a -> IO (Either IOError a)+try f          =  catch (do r <- f+                            return (Right r))+                        (return . Left)+#endif++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+-- -----------------------------------------------------------------------------+-- 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 t location maybe_hdl maybe_filename =+               IOError{ ioe_type = t, +                        ioe_location = location,+                        ioe_description = "",+                        ioe_handle = maybe_hdl, +                        ioe_filename = maybe_filename+                        }+#ifdef __NHC__+mkIOError EOF       location maybe_hdl maybe_filename =+    EOFError location (fromJust maybe_hdl)+mkIOError UserError location maybe_hdl maybe_filename =+    UserError location ""+mkIOError t         location maybe_hdl maybe_filename =+    NHC.FFI.mkIOError location maybe_filename maybe_handle (ioeTypeToInt t)+  where+    ioeTypeToInt AlreadyExists     = fromEnum EEXIST+    ioeTypeToInt NoSuchThing       = fromEnum ENOENT+    ioeTypeToInt ResourceBusy      = fromEnum EBUSY+    ioeTypeToInt ResourceExhausted = fromEnum ENOSPC+    ioeTypeToInt IllegalOperation  = fromEnum EPERM+    ioeTypeToInt PermissionDenied  = fromEnum EACCES+#endif+#endif /* __GLASGOW_HASKELL__ || __HUGS__ */++#ifndef __NHC__+-- -----------------------------------------------------------------------------+-- IOErrorType++-- | An error indicating that an 'IO' operation failed because+-- one of its arguments already exists.+isAlreadyExistsError :: IOError -> Bool+isAlreadyExistsError = isAlreadyExistsErrorType    . ioeGetErrorType++-- | An error indicating that an 'IO' operation failed because+-- one of its arguments does not exist.+isDoesNotExistError :: IOError -> Bool+isDoesNotExistError  = isDoesNotExistErrorType     . ioeGetErrorType++-- | 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  = isAlreadyInUseErrorType     . ioeGetErrorType++-- | An error indicating that an 'IO' operation failed because+-- the device is full.+isFullError         :: IOError -> Bool+isFullError          = isFullErrorType             . ioeGetErrorType++-- | An error indicating that an 'IO' operation failed because+-- the end of file has been reached.+isEOFError          :: IOError -> Bool+isEOFError           = isEOFErrorType              . ioeGetErrorType++-- | 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   = isIllegalOperationErrorType . ioeGetErrorType++-- | 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    = isPermissionErrorType       . ioeGetErrorType++-- | A programmer-defined error value constructed using 'userError'.+isUserError         :: IOError -> Bool+isUserError          = isUserErrorType             . ioeGetErrorType+#endif /* __NHC__ */++-- -----------------------------------------------------------------------------+-- IOErrorTypes++#ifdef __NHC__+data IOErrorType = AlreadyExists | NoSuchThing | ResourceBusy+                 | ResourceExhausted | EOF | IllegalOperation+                 | PermissionDenied | UserError+#endif++-- | I\/O error where the operation failed because one of its arguments+-- already exists.+alreadyExistsErrorType   :: IOErrorType+alreadyExistsErrorType    = AlreadyExists++-- | I\/O error where the operation failed because one of its arguments+-- does not exist.+doesNotExistErrorType    :: IOErrorType+doesNotExistErrorType     = NoSuchThing++-- | I\/O error where the operation failed because one of its arguments+-- is a single-use resource, which is already being used.+alreadyInUseErrorType    :: IOErrorType+alreadyInUseErrorType     = ResourceBusy++-- | I\/O error where the operation failed because the device is full.+fullErrorType            :: IOErrorType+fullErrorType             = ResourceExhausted++-- | I\/O error where the operation failed because the end of file has+-- been reached.+eofErrorType             :: IOErrorType+eofErrorType              = EOF++-- | I\/O error where the operation is not possible.+illegalOperationErrorType :: IOErrorType+illegalOperationErrorType = IllegalOperation++-- | I\/O error where the operation failed because the user does not+-- have sufficient operating system privilege to perform that operation.+permissionErrorType      :: IOErrorType+permissionErrorType       = PermissionDenied++-- | I\/O error that is programmer-defined.+userErrorType            :: IOErrorType+userErrorType             = UserError++-- -----------------------------------------------------------------------------+-- IOErrorType predicates++-- | I\/O error where the operation failed because one of its arguments+-- already exists.+isAlreadyExistsErrorType :: IOErrorType -> Bool+isAlreadyExistsErrorType AlreadyExists = True+isAlreadyExistsErrorType _ = False++-- | I\/O error where the operation failed because one of its arguments+-- does not exist.+isDoesNotExistErrorType :: IOErrorType -> Bool+isDoesNotExistErrorType NoSuchThing = True+isDoesNotExistErrorType _ = False++-- | I\/O error where the operation failed because one of its arguments+-- is a single-use resource, which is already being used.+isAlreadyInUseErrorType :: IOErrorType -> Bool+isAlreadyInUseErrorType ResourceBusy = True+isAlreadyInUseErrorType _ = False++-- | I\/O error where the operation failed because the device is full.+isFullErrorType :: IOErrorType -> Bool+isFullErrorType ResourceExhausted = True+isFullErrorType _ = False++-- | I\/O error where the operation failed because the end of file has+-- been reached.+isEOFErrorType :: IOErrorType -> Bool+isEOFErrorType EOF = True+isEOFErrorType _ = False++-- | I\/O error where the operation is not possible.+isIllegalOperationErrorType :: IOErrorType -> Bool+isIllegalOperationErrorType IllegalOperation = True+isIllegalOperationErrorType _ = False++-- | I\/O error where the operation failed because the user does not+-- have sufficient operating system privilege to perform that operation.+isPermissionErrorType :: IOErrorType -> Bool+isPermissionErrorType PermissionDenied = True+isPermissionErrorType _ = False++-- | I\/O error that is programmer-defined.+isUserErrorType :: IOErrorType -> Bool+isUserErrorType UserError = True+isUserErrorType _ = False++-- -----------------------------------------------------------------------------+-- Miscellaneous++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+ioeGetErrorType       :: IOError -> IOErrorType+ioeGetErrorString     :: IOError -> String+ioeGetLocation        :: IOError -> String+ioeGetHandle          :: IOError -> Maybe Handle+ioeGetFileName        :: IOError -> Maybe FilePath++ioeGetErrorType ioe = ioe_type ioe++ioeGetErrorString ioe+   | isUserErrorType (ioe_type ioe) = ioe_description ioe+   | otherwise                      = show (ioe_type ioe)++ioeGetLocation ioe = ioe_location ioe++ioeGetHandle ioe = ioe_handle ioe++ioeGetFileName ioe = ioe_filename ioe++ioeSetErrorType   :: IOError -> IOErrorType -> IOError+ioeSetErrorString :: IOError -> String      -> IOError+ioeSetLocation    :: IOError -> String      -> IOError+ioeSetHandle      :: IOError -> Handle      -> IOError+ioeSetFileName    :: IOError -> FilePath    -> IOError++ioeSetErrorType   ioe errtype  = ioe{ ioe_type = errtype }+ioeSetErrorString ioe str      = ioe{ ioe_description = str }+ioeSetLocation    ioe str      = ioe{ ioe_location = str }+ioeSetHandle      ioe hdl      = ioe{ ioe_handle = Just hdl }+ioeSetFileName    ioe filename = ioe{ ioe_filename = Just filename }++-- | Catch any 'IOError' that occurs in the computation and throw a+-- modified version.+modifyIOError :: (IOError -> IOError) -> IO a -> IO a+modifyIOError f io = catch io (\e -> ioError (f e))++-- -----------------------------------------------------------------------------+-- annotating an IOError++-- | Adds a location description and maybe a file path and file handle+-- to an 'IOError'.  If any of the file handle or file path is not given+-- the corresponding value in the 'IOError' remains unaltered.+annotateIOError :: IOError +              -> String +              -> Maybe Handle +              -> Maybe FilePath +              -> IOError +annotateIOError (IOError ohdl errTy _ str opath) loc hdl path = +  IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath)+  where+    Nothing `mplus` ys = ys+    xs      `mplus` _  = xs+#endif /* __GLASGOW_HASKELL__ || __HUGS__ */++#if 0 /*__NHC__*/+annotateIOError (IOError msg file hdl code) msg' file' hdl' =+    IOError (msg++'\n':msg') (file`mplus`file') (hdl`mplus`hdl') code+annotateIOError (EOFError msg hdl) msg' file' hdl' =+    EOFError (msg++'\n':msg') (hdl`mplus`hdl')+annotateIOError (UserError loc msg) msg' file' hdl' =+    UserError loc (msg++'\n':msg')+annotateIOError (PatternError loc) msg' file' hdl' =+    PatternError (loc++'\n':msg')+#endif
lib/base/src/System/IO/Unsafe.hs view
@@ -1,6 +1,37 @@-{-# OPTIONS -N #-}-module System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO) where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  System.IO.Unsafe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- \"Unsafe\" IO operations.+--+----------------------------------------------------------------------------- -import Lhc.IO+module System.IO.Unsafe (+   -- * Unsafe 'System.IO.IO' operations+   unsafePerformIO,     -- :: IO a -> a+   unsafeInterleaveIO,  -- :: IO a -> IO a+  ) where +#ifdef __GLASGOW_HASKELL__+import GHC.IOBase (unsafePerformIO, unsafeInterleaveIO)+#endif +#ifdef __HUGS__+import Hugs.IOExts (unsafePerformIO, unsafeInterleaveIO)+#endif++#ifdef __NHC__+import NHC.Internal (unsafePerformIO)+#endif++#if !__GLASGOW_HASKELL__ && !__HUGS__+unsafeInterleaveIO :: IO a -> IO a+unsafeInterleaveIO f = return (unsafePerformIO f)+#endif
− lib/base/src/System/Info.hs 
@@ -1,6 +0,0 @@-{-# OPTIONS_LHC -N #-}-module System.Info where---compilerName = "lhc"-compilerVersion = "0"
− lib/base/src/System/Locale.hs 
@@ -1,30 +0,0 @@-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/base/src/System/Posix/Internals.hs view
@@ -0,0 +1,530 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_HADDOCK hide #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Posix.Internals+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (requires POSIX)+--+-- POSIX support layer for the standard libraries.+-- This library is built on *every* platform, including Win32.+--+-- Non-posix compliant in order to support the following features:+--      * S_ISSOCK (no sockets in POSIX)+--+-----------------------------------------------------------------------------++-- #hide+module System.Posix.Internals where+++#if ! (defined(mingw32_HOST_OS) || defined(__MINGW32__))+import Control.Monad+#endif+import System.Posix.Types++import Foreign+import Foreign.C++import Data.Bits+import Data.Maybe++#if __GLASGOW_HASKELL__+import GHC.Base+import GHC.Num+import GHC.Real+import GHC.IOBase+#elif __HUGS__+import Hugs.Prelude (IOException(..), IOErrorType(..))+import Hugs.IO (IOMode(..))+#else+import System.IO+#endif++#ifdef __HUGS__+{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}+#endif++-- ---------------------------------------------------------------------------+-- Types++type CDir       = ()+type CDirent    = ()+type CFLock     = ()+type CGroup     = ()+type CLconv     = ()+type CPasswd    = ()+type CSigaction = ()+type CSigset    = ()+type CStat      = ()+type CTermios   = ()+type CTm        = ()+type CTms       = ()+type CUtimbuf   = ()+type CUtsname   = ()++#ifndef __GLASGOW_HASKELL__+type FD = CInt+#endif++-- ---------------------------------------------------------------------------+-- stat()-related stuff++fdFileSize :: FD -> IO Integer+fdFileSize fd = +  allocaBytes sizeof_stat $ \ p_stat -> do+    throwErrnoIfMinus1Retry "fileSize" $+        c_fstat fd p_stat+    c_mode <- st_mode p_stat :: IO CMode +    if not (s_isreg c_mode)+        then return (-1)+        else do+    c_size <- st_size p_stat+    return (fromIntegral c_size)++data FDType  = Directory | Stream | RegularFile | RawDevice+               deriving (Eq)++fileType :: FilePath -> IO FDType+fileType file =+  allocaBytes sizeof_stat $ \ p_stat -> do+  withCString file $ \p_file -> do+    throwErrnoIfMinus1Retry "fileType" $+      c_stat p_file p_stat+    statGetType p_stat++-- NOTE: On Win32 platforms, this will only work with file descriptors+-- referring to file handles. i.e., it'll fail for socket FDs.+fdStat :: FD -> IO (FDType, CDev, CIno)+fdStat fd = +  allocaBytes sizeof_stat $ \ p_stat -> do+    throwErrnoIfMinus1Retry "fdType" $+        c_fstat fd p_stat+    ty <- statGetType p_stat+    dev <- st_dev p_stat+    ino <- st_ino p_stat+    return (ty,dev,ino)+    +fdType :: FD -> IO FDType+fdType fd = do (ty,_,_) <- fdStat fd; return ty++statGetType :: Ptr CStat -> IO FDType+statGetType p_stat = do+  c_mode <- st_mode p_stat :: IO CMode+  case () of+      _ | s_isdir c_mode        -> return Directory+        | s_isfifo c_mode || s_issock c_mode || s_ischr  c_mode+                                -> return Stream+        | s_isreg c_mode        -> return RegularFile+         -- Q: map char devices to RawDevice too?+        | s_isblk c_mode        -> return RawDevice+        | otherwise             -> ioError ioe_unknownfiletype+    +ioe_unknownfiletype :: IOException+ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"+                        "unknown file type" Nothing++#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))+closeFd :: Bool -> CInt -> IO CInt+closeFd isStream fd +  | isStream  = c_closesocket fd+  | otherwise = c_close fd++foreign import stdcall unsafe "HsBase.h closesocket"+   c_closesocket :: CInt -> IO CInt+#endif++fdGetMode :: FD -> IO IOMode+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+fdGetMode _ = do+    -- We don't have a way of finding out which flags are set on FDs+    -- on Windows, so make a handle that thinks that anything goes.+    let flags = o_RDWR+#else+fdGetMode fd = do+    flags <- throwErrnoIfMinus1Retry "fdGetMode" +                (c_fcntl_read fd const_f_getfl)+#endif+    let+       wH  = (flags .&. o_WRONLY) /= 0+       aH  = (flags .&. o_APPEND) /= 0+       rwH = (flags .&. o_RDWR) /= 0++       mode+         | wH && aH  = AppendMode+         | wH        = WriteMode+         | rwH       = ReadWriteMode+         | otherwise = ReadMode+          +    return mode++-- ---------------------------------------------------------------------------+-- Terminal-related stuff++fdIsTTY :: FD -> IO Bool+fdIsTTY fd = c_isatty fd >>= return.toBool++#if defined(HTYPE_TCFLAG_T)++setEcho :: FD -> Bool -> IO ()+setEcho fd on = do+  tcSetAttr fd $ \ p_tios -> do+    lflag <- c_lflag p_tios :: IO CTcflag+    let new_lflag+         | on        = lflag .|. fromIntegral const_echo+         | otherwise = lflag .&. complement (fromIntegral const_echo)+    poke_c_lflag p_tios (new_lflag :: CTcflag)++getEcho :: FD -> IO Bool+getEcho fd = do+  tcSetAttr fd $ \ p_tios -> do+    lflag <- c_lflag p_tios :: IO CTcflag+    return ((lflag .&. fromIntegral const_echo) /= 0)++setCooked :: FD -> Bool -> IO ()+setCooked fd cooked = +  tcSetAttr fd $ \ p_tios -> do++    -- turn on/off ICANON+    lflag <- c_lflag p_tios :: IO CTcflag+    let new_lflag | cooked    = lflag .|. (fromIntegral const_icanon)+                  | otherwise = lflag .&. complement (fromIntegral const_icanon)+    poke_c_lflag p_tios (new_lflag :: CTcflag)++    -- set VMIN & VTIME to 1/0 respectively+    when (not cooked) $ do+            c_cc <- ptr_c_cc p_tios+            let vmin  = (c_cc `plusPtr` (fromIntegral const_vmin))  :: Ptr Word8+                vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8+            poke vmin  1+            poke vtime 0++tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a+tcSetAttr fd fun = do+     allocaBytes sizeof_termios  $ \p_tios -> do+        throwErrnoIfMinus1Retry "tcSetAttr"+           (c_tcgetattr fd p_tios)++#ifdef __GLASGOW_HASKELL__+        -- Save a copy of termios, if this is a standard file descriptor.+        -- These terminal settings are restored in hs_exit().+        when (fd <= 2) $ do+          p <- get_saved_termios fd+          when (p == nullPtr) $ do+             saved_tios <- mallocBytes sizeof_termios+             copyBytes saved_tios p_tios sizeof_termios+             set_saved_termios fd saved_tios+#endif++        -- tcsetattr() when invoked by a background process causes the process+        -- to be sent SIGTTOU regardless of whether the process has TOSTOP set+        -- in its terminal flags (try it...).  This function provides a+        -- wrapper which temporarily blocks SIGTTOU around the call, making it+        -- transparent.+        allocaBytes sizeof_sigset_t $ \ p_sigset -> do+        allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do+             c_sigemptyset p_sigset+             c_sigaddset   p_sigset const_sigttou+             c_sigprocmask const_sig_block p_sigset p_old_sigset+             r <- fun p_tios  -- do the business+             throwErrnoIfMinus1Retry_ "tcSetAttr" $+                 c_tcsetattr fd const_tcsanow p_tios+             c_sigprocmask const_sig_setmask p_old_sigset nullPtr+             return r++#ifdef __GLASGOW_HASKELL__+foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"+   get_saved_termios :: CInt -> IO (Ptr CTermios)++foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"+   set_saved_termios :: CInt -> (Ptr CTermios) -> IO ()+#endif++#else++-- 'raw' mode for Win32 means turn off 'line input' (=> buffering and+-- character translation for the console.) The Win32 API for doing+-- this is GetConsoleMode(), which also requires echoing to be disabled+-- when turning off 'line input' processing. Notice that turning off+-- 'line input' implies enter/return is reported as '\r' (and it won't+-- report that character until another character is input..odd.) This+-- latter feature doesn't sit too well with IO actions like IO.hGetLine..+-- consider yourself warned.+setCooked :: FD -> Bool -> IO ()+setCooked fd cooked = do+  x <- set_console_buffering fd (if cooked then 1 else 0)+  if (x /= 0)+   then ioError (ioe_unk_error "setCooked" "failed to set buffering")+   else return ()++ioe_unk_error :: String -> String -> IOException+ioe_unk_error loc msg + = IOError Nothing OtherError loc msg Nothing++-- Note: echoing goes hand in hand with enabling 'line input' / raw-ness+-- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.+setEcho :: FD -> Bool -> IO ()+setEcho fd on = do+  x <- set_console_echo fd (if on then 1 else 0)+  if (x /= 0)+   then ioError (ioe_unk_error "setEcho" "failed to set echoing")+   else return ()++getEcho :: FD -> IO Bool+getEcho fd = do+  r <- get_console_echo fd+  if (r == (-1))+   then ioError (ioe_unk_error "getEcho" "failed to get echoing")+   else return (r == 1)++foreign import ccall unsafe "consUtils.h set_console_buffering__"+   set_console_buffering :: CInt -> CInt -> IO CInt++foreign import ccall unsafe "consUtils.h set_console_echo__"+   set_console_echo :: CInt -> CInt -> IO CInt++foreign import ccall unsafe "consUtils.h get_console_echo__"+   get_console_echo :: CInt -> IO CInt++#endif++-- ---------------------------------------------------------------------------+-- Turning on non-blocking for a file descriptor++setNonBlockingFD :: FD -> IO ()+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+setNonBlockingFD fd = do+  flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"+                 (c_fcntl_read fd const_f_getfl)+  -- An error when setting O_NONBLOCK isn't fatal: on some systems +  -- there are certain file handles on which this will fail (eg. /dev/null+  -- on FreeBSD) so we throw away the return code from fcntl_write.+  unless (testBit flags (fromIntegral o_NONBLOCK)) $ do+    c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK))+    return ()+#else++-- bogus defns for win32+setNonBlockingFD _ = return ()++#endif++-- -----------------------------------------------------------------------------+-- Set close-on-exec for a file descriptor++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+setCloseOnExec :: FD -> IO ()+setCloseOnExec fd = do+  throwErrnoIfMinus1 "setCloseOnExec" $+    c_fcntl_write fd const_f_setfd const_fd_cloexec+  return ()+#endif++-- -----------------------------------------------------------------------------+-- foreign imports++foreign import ccall unsafe "HsBase.h access"+   c_access :: CString -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h chmod"+   c_chmod :: CString -> CMode -> IO CInt++foreign import ccall unsafe "HsBase.h close"+   c_close :: CInt -> IO CInt++foreign import ccall unsafe "HsBase.h closedir" +   c_closedir :: Ptr CDir -> IO CInt++foreign import ccall unsafe "HsBase.h creat"+   c_creat :: CString -> CMode -> IO CInt++foreign import ccall unsafe "HsBase.h dup"+   c_dup :: CInt -> IO CInt++foreign import ccall unsafe "HsBase.h dup2"+   c_dup2 :: CInt -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_fstat"+   c_fstat :: CInt -> Ptr CStat -> IO CInt++foreign import ccall unsafe "HsBase.h isatty"+   c_isatty :: CInt -> IO CInt++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+foreign import ccall unsafe "HsBase.h __hscore_lseek"+   c_lseek :: CInt -> Int64 -> CInt -> IO Int64+#else+foreign import ccall unsafe "HsBase.h __hscore_lseek"+   c_lseek :: CInt -> COff -> CInt -> IO COff+#endif++foreign import ccall unsafe "HsBase.h __hscore_lstat"+   lstat :: CString -> Ptr CStat -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_open"+   c_open :: CString -> CInt -> CMode -> IO CInt++foreign import ccall unsafe "HsBase.h opendir" +   c_opendir :: CString  -> IO (Ptr CDir)++foreign import ccall unsafe "HsBase.h __hscore_mkdir"+   mkdir :: CString -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h read" +   c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize++foreign import ccall unsafe "HsBase.h rewinddir"+   c_rewinddir :: Ptr CDir -> IO ()++foreign import ccall unsafe "HsBase.h __hscore_stat"+   c_stat :: CString -> Ptr CStat -> IO CInt++foreign import ccall unsafe "HsBase.h umask"+   c_umask :: CMode -> IO CMode++foreign import ccall unsafe "HsBase.h write" +   c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize++foreign import ccall unsafe "HsBase.h __hscore_ftruncate"+   c_ftruncate :: CInt -> COff -> IO CInt++foreign import ccall unsafe "HsBase.h unlink"+   c_unlink :: CString -> IO CInt++foreign import ccall unsafe "HsBase.h getpid"+   c_getpid :: IO CPid++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+foreign import ccall unsafe "HsBase.h fcntl"+   c_fcntl_read  :: CInt -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h fcntl"+   c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt++foreign import ccall unsafe "HsBase.h fcntl"+   c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt++foreign import ccall unsafe "HsBase.h fork"+   c_fork :: IO CPid ++foreign import ccall unsafe "HsBase.h link"+   c_link :: CString -> CString -> IO CInt++foreign import ccall unsafe "HsBase.h mkfifo"+   c_mkfifo :: CString -> CMode -> IO CInt++foreign import ccall unsafe "HsBase.h pipe"+   c_pipe :: Ptr CInt -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_sigemptyset"+   c_sigemptyset :: Ptr CSigset -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_sigaddset"+   c_sigaddset :: Ptr CSigset -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h sigprocmask"+   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt++foreign import ccall unsafe "HsBase.h tcgetattr"+   c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt++foreign import ccall unsafe "HsBase.h tcsetattr"+   c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt++foreign import ccall unsafe "HsBase.h utime"+   c_utime :: CString -> Ptr CUtimbuf -> IO CInt++foreign import ccall unsafe "HsBase.h waitpid"+   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid+#endif++-- traversing directories+foreign import ccall unsafe "dirUtils.h __hscore_readdir"+  readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt+ +foreign import ccall unsafe "HsBase.h __hscore_free_dirent"+  freeDirEnt  :: Ptr CDirent -> IO ()+ +foreign import ccall unsafe "HsBase.h __hscore_end_of_dir"+  end_of_dir :: CInt+ +foreign import ccall unsafe "HsBase.h __hscore_d_name"+  d_name :: Ptr CDirent -> IO CString++-- POSIX flags only:+foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_rdwr"   o_RDWR   :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_creat"  o_CREAT  :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_excl"   o_EXCL   :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_trunc"  o_TRUNC  :: CInt++-- non-POSIX flags.+foreign import ccall unsafe "HsBase.h __hscore_o_noctty"   o_NOCTTY   :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_nonblock" o_NONBLOCK :: CInt+foreign import ccall unsafe "HsBase.h __hscore_o_binary"   o_BINARY   :: CInt++foreign import ccall unsafe "HsBase.h __hscore_s_isreg"  c_s_isreg  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_ischr"  c_s_ischr  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_isblk"  c_s_isblk  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_isdir"  c_s_isdir  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_isfifo" c_s_isfifo :: CMode -> CInt++s_isreg  :: CMode -> Bool+s_isreg cm = c_s_isreg cm /= 0+s_ischr  :: CMode -> Bool+s_ischr cm = c_s_ischr cm /= 0+s_isblk  :: CMode -> Bool+s_isblk cm = c_s_isblk cm /= 0+s_isdir  :: CMode -> Bool+s_isdir cm = c_s_isdir cm /= 0+s_isfifo :: CMode -> Bool+s_isfifo cm = c_s_isfifo cm /= 0++foreign import ccall unsafe "HsBase.h __hscore_sizeof_stat" sizeof_stat :: Int+foreign import ccall unsafe "HsBase.h __hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime+#ifdef mingw32_HOST_OS+foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO Int64+#else+foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO COff+#endif+foreign import ccall unsafe "HsBase.h __hscore_st_mode" st_mode :: Ptr CStat -> IO CMode+foreign import ccall unsafe "HsBase.h __hscore_st_dev" st_dev :: Ptr CStat -> IO CDev+foreign import ccall unsafe "HsBase.h __hscore_st_ino" st_ino :: Ptr CStat -> IO CIno++foreign import ccall unsafe "HsBase.h __hscore_echo"         const_echo :: CInt+foreign import ccall unsafe "HsBase.h __hscore_tcsanow"      const_tcsanow :: CInt+foreign import ccall unsafe "HsBase.h __hscore_icanon"       const_icanon :: CInt+foreign import ccall unsafe "HsBase.h __hscore_vmin"         const_vmin   :: CInt+foreign import ccall unsafe "HsBase.h __hscore_vtime"        const_vtime  :: CInt+foreign import ccall unsafe "HsBase.h __hscore_sigttou"      const_sigttou :: CInt+foreign import ccall unsafe "HsBase.h __hscore_sig_block"    const_sig_block :: CInt+foreign import ccall unsafe "HsBase.h __hscore_sig_setmask"  const_sig_setmask :: CInt+foreign import ccall unsafe "HsBase.h __hscore_f_getfl"      const_f_getfl :: CInt+foreign import ccall unsafe "HsBase.h __hscore_f_setfl"      const_f_setfl :: CInt+foreign import ccall unsafe "HsBase.h __hscore_f_setfd"      const_f_setfd :: CInt+foreign import ccall unsafe "HsBase.h __hscore_fd_cloexec"   const_fd_cloexec :: CLong++#if defined(HTYPE_TCFLAG_T)+foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios"  sizeof_termios :: Int+foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int++foreign import ccall unsafe "HsBase.h __hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag+foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()+foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)+#endif++s_issock :: CMode -> Bool+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+s_issock cmode = c_s_issock cmode /= 0+foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt+#else+s_issock _ = False+#endif
+ lib/base/src/System/Posix/Types.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Posix.Types+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires POSIX)+--+-- POSIX data types: Haskell equivalents of the types defined by the+-- @\<sys\/types.h>@ C header on a POSIX system.+--+-----------------------------------------------------------------------------+#ifdef __NHC__+#define HTYPE_DEV_T+#define HTYPE_INO_T+#define HTYPE_MODE_T+#define HTYPE_OFF_T+#define HTYPE_PID_T+#define HTYPE_SSIZE_T+#define HTYPE_GID_T+#define HTYPE_NLINK_T+#define HTYPE_UID_T+#define HTYPE_CC_T+#define HTYPE_SPEED_T+#define HTYPE_TCFLAG_T+#define HTYPE_RLIM_T+#define HTYPE_NLINK_T+#define HTYPE_UID_T+#define HTYPE_GID_T+#else+#endif++module System.Posix.Types (++  -- * POSIX data types+  CDev,+  CIno,+  CMode,+  COff,+  CPid,+  CSsize,++#if defined(HTYPE_GID_T)+  CGid,+#endif+#if defined(HTYPE_NLINK_T)+  CNlink,+#endif+#if defined(HTYPE_UID_T)+  CUid,+#endif+#if defined(HTYPE_CC_T)+  CCc,+#endif+#if defined(HTYPE_SPEED_T)+  CSpeed,+#endif+#if defined(HTYPE_TCFLAG_T)+  CTcflag,+#endif+#if defined(HTYPE_RLIM_T)+  CRLim,+#endif++  Fd(..),++#if defined(HTYPE_NLINK_T)+  LinkCount,+#endif+#if defined(HTYPE_UID_T)+  UserID,+#endif+#if defined(HTYPE_GID_T)+  GroupID,+#endif++  ByteCount,+  ClockTick,+  EpochTime,+  FileOffset,+  ProcessID,+  ProcessGroupID,+  DeviceID,+  FileID,+  FileMode,+  Limit+ ) where++#ifdef __NHC__+import NHC.PosixTypes+import Foreign.C+#else++import Foreign+import Foreign.C+--import Data.Typeable+import Data.Bits++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Prim+import GHC.Read+import GHC.Show+#else+import Control.Monad+#endif++#include "CTypes.h"++newtype CDev = CDev Word64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)+newtype CIno = CIno Word64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)+newtype CMode = CMode Word32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)+newtype CPid = CPid Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)+newtype COff = COff Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)+newtype CSsize = CSsize Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)++#if defined(HTYPE_DEV_T)+ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T)+#endif+#if defined(HTYPE_INO_T)+INTEGRAL_TYPE(CIno,tyConCIno,"CIno",HTYPE_INO_T)+#endif+#if defined(HTYPE_MODE_T)+INTEGRAL_TYPE(CMode,tyConCMode,"CMode",HTYPE_MODE_T)+#endif+#if defined(HTYPE_OFF_T)+INTEGRAL_TYPE(COff,tyConCOff,"COff",HTYPE_OFF_T)+#endif+#if defined(HTYPE_PID_T)+INTEGRAL_TYPE(CPid,tyConCPid,"CPid",HTYPE_PID_T)+#endif++#if defined(HTYPE_SSIZE_T)+INTEGRAL_TYPE(CSsize,tyConCSsize,"CSsize",HTYPE_SSIZE_T)+#endif++#if defined(HTYPE_GID_T)+INTEGRAL_TYPE(CGid,tyConCGid,"CGid",HTYPE_GID_T)+#endif+#if defined(HTYPE_NLINK_T)+INTEGRAL_TYPE(CNlink,tyConCNlink,"CNlink",HTYPE_NLINK_T)+#endif++#if defined(HTYPE_UID_T)+INTEGRAL_TYPE(CUid,tyConCUid,"CUid",HTYPE_UID_T)+#endif+#if defined(HTYPE_CC_T)+ARITHMETIC_TYPE(CCc,tyConCCc,"CCc",HTYPE_CC_T)+#endif+#if defined(HTYPE_SPEED_T)+ARITHMETIC_TYPE(CSpeed,tyConCSpeed,"CSpeed",HTYPE_SPEED_T)+#endif+#if defined(HTYPE_TCFLAG_T)+INTEGRAL_TYPE(CTcflag,tyConCTcflag,"CTcflag",HTYPE_TCFLAG_T)+#endif+#if defined(HTYPE_RLIM_T)+INTEGRAL_TYPE(CRLim,tyConCRlim,"CRLim",HTYPE_RLIM_T)+#endif++-- ToDo: blksize_t, clockid_t, blkcnt_t, fsblkcnt_t, fsfilcnt_t, id_t, key_t+-- suseconds_t, timer_t, useconds_t++-- Make an Fd type rather than using CInt everywhere+{-INTEGRAL_TYPE(Fd,tyConFd,"Fd",CInt)-}+newtype Fd = Fd CInt deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum)+++-- nicer names, and backwards compatibility with POSIX library:+#if defined(HTYPE_NLINK_T)+type LinkCount      = CNlink+#endif+#if defined(HTYPE_UID_T)+type UserID         = CUid+#endif+#if defined(HTYPE_GID_T)+type GroupID        = CGid+#endif++#endif /* !__NHC__ */++type ByteCount      = CSize+type ClockTick      = CClock+type EpochTime      = CTime+type DeviceID       = CDev+type FileID         = CIno+type FileMode       = CMode+type ProcessID      = CPid+type FileOffset     = COff+type ProcessGroupID = CPid+type Limit          = CLong+
− lib/base/src/System/Random.hs 
@@ -1,268 +0,0 @@-{-# OPTIONS_LHC -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 Numeric-import Foreign.Storable-import Foreign.Ptr----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 "&lhc_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/base/src/System/Time.hs 
@@ -1,232 +0,0 @@-{-# OPTIONS_LHC -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--data ClockTime = TOD !Integer !Integer -- Implementation-dependent-    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) 0)--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 c_psec) =-	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))-                                                       -- 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 pa) (TOD sb pb) =-    noTimeDiff{ tdSec     = fromIntegral (sa - sb)-                -- FIXME: can handle just 68 years...-              , tdPicosec = pa - pb-              }--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/base/src/Text/ParserCombinators/ReadP.hs view
@@ -0,0 +1,524 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.ReadP+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (local universal quantification)+--+-- This is a library of parser combinators, originally written by Koen Claessen.+-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with+-- other parsers.  The '(+++)' choice combinator is genuinely commutative;+-- it makes no difference which branch is \"shorter\".++-----------------------------------------------------------------------------++module Text.ParserCombinators.ReadP+  ( +  -- * The 'ReadP' type+#ifndef __NHC__+  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus+#else+  ReadPN,     -- :: * -> * -> *; instance Functor, Monad, MonadPlus+#endif+  +  -- * Primitive operations+  get,        -- :: ReadP Char+  look,       -- :: ReadP String+  (+++),      -- :: ReadP a -> ReadP a -> ReadP a+  (<++),      -- :: ReadP a -> ReadP a -> ReadP a+  gather,     -- :: ReadP a -> ReadP (String, a)+  +  -- * Other operations+  pfail,      -- :: ReadP a+  satisfy,    -- :: (Char -> Bool) -> ReadP Char+  char,       -- :: Char -> ReadP Char+  string,     -- :: String -> ReadP String+  munch,      -- :: (Char -> Bool) -> ReadP String+  munch1,     -- :: (Char -> Bool) -> ReadP String+  skipSpaces, -- :: ReadP ()+  choice,     -- :: [ReadP a] -> ReadP a+  count,      -- :: Int -> ReadP a -> ReadP [a]+  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a+  option,     -- :: a -> ReadP a -> ReadP a+  optional,   -- :: ReadP a -> ReadP ()+  many,       -- :: ReadP a -> ReadP [a]+  many1,      -- :: ReadP a -> ReadP [a]+  skipMany,   -- :: ReadP a -> ReadP ()+  skipMany1,  -- :: ReadP a -> ReadP ()+  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]+  +  -- * Running a parser+  ReadS,      -- :: *; = String -> [(a,String)]+  readP_to_S, -- :: ReadP a -> ReadS a+  readS_to_P, -- :: ReadS a -> ReadP a+  +  -- * Properties+  -- $properties+  )+ where++import Control.Monad( MonadPlus(..), sequence, liftM2 )++#ifdef __GLASGOW_HASKELL__+#ifndef __HADDOCK__+import {-# SOURCE #-} GHC.Unicode ( isSpace  )+#endif+import GHC.List ( replicate )+import GHC.Base+#else+import Data.Char( isSpace )+#endif++infixr 5 +++, <++++#ifdef __GLASGOW_HASKELL__+------------------------------------------------------------------------+-- ReadS++-- | A parser for a type @a@, represented as a function that takes a+-- 'String' and returns a list of possible parses as @(a,'String')@ pairs.+--+-- Note that this kind of backtracking parser is very inefficient;+-- reading a large structure may be quite slow (cf 'ReadP').+type ReadS a = String -> [(a,String)]+#endif++-- ---------------------------------------------------------------------------+-- The P type+-- is representation type -- should be kept abstract++data P a+  = Get (Char -> P a)+  | Look (String -> P a)+  | Fail+  | Result a (P a)+  | Final [(a,String)] -- invariant: list is non-empty!++-- Monad, MonadPlus++instance Monad P where+  return x = Result x Fail++  (Get f)      >>= k = Get (\c -> f c >>= k)+  (Look f)     >>= k = Look (\s -> f s >>= k)+  Fail         >>= _ = Fail+  (Result x p) >>= k = k x `mplus` (p >>= k)+  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]++  fail _ = Fail++instance MonadPlus P where+  mzero = Fail++  -- most common case: two gets are combined+  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)+  +  -- results are delivered as soon as possible+  Result x p `mplus` q          = Result x (p `mplus` q)+  p          `mplus` Result x q = Result x (p `mplus` q)++  -- fail disappears+  Fail       `mplus` p          = p+  p          `mplus` Fail       = p++  -- two finals are combined+  -- final + look becomes one look and one final (=optimization)+  -- final + sthg else becomes one look and one final+  Final r    `mplus` Final t    = Final (r ++ t)+  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))+  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))+  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))+  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))++  -- two looks are combined (=optimization)+  -- look + sthg else floats upwards+  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)+  Look f     `mplus` p          = Look (\s -> f s `mplus` p)+  p          `mplus` Look f     = Look (\s -> p `mplus` f s)++-- ---------------------------------------------------------------------------+-- The ReadP type++#ifndef __NHC__+newtype ReadP a = R (forall b . (a -> P b) -> P b)+#else+#define ReadP  (ReadPN b)+newtype ReadPN b a = R ((a -> P b) -> P b)+#endif++-- Functor, Monad, MonadPlus++instance Functor ReadP where+  fmap h (R f) = R (\k -> f (k . h))++instance Monad ReadP where+  return x  = R (\k -> k x)+  fail _    = R (\_ -> Fail)+  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))++instance MonadPlus ReadP where+  mzero = pfail+  mplus = (+++)++-- ---------------------------------------------------------------------------+-- Operations over P++final :: [(a,String)] -> P a+-- Maintains invariant for Final constructor+final [] = Fail+final r  = Final r++run :: P a -> ReadS a+run (Get f)      (c:s) = run (f c) s+run (Look f)     s     = run (f s) s+run (Result x p) s     = (x,s) : run p s+run (Final r)    _     = r+run _            _     = []++-- ---------------------------------------------------------------------------+-- Operations over ReadP++get :: ReadP Char+-- ^ Consumes and returns the next character.+--   Fails if there is no input left.+get = R Get++look :: ReadP String+-- ^ Look-ahead: returns the part of the input that is left, without+--   consuming it.+look = R Look++pfail :: ReadP a+-- ^ Always fails.+pfail = R (\_ -> Fail)++(+++) :: ReadP a -> ReadP a -> ReadP a+-- ^ Symmetric choice.+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)++#ifndef __NHC__+(<++) :: ReadP a -> ReadP a -> ReadP a+#else+(<++) :: ReadPN a a -> ReadPN a a -> ReadPN a a+#endif+-- ^ Local, exclusive, left-biased choice: If left parser+--   locally produces any result at all, then right parser is+--   not used.+#ifdef __GLASGOW_HASKELL__+R f0 <++ q =+  do s <- look+     probe (f0 return) s 0#+ where+  probe (Get f)        (c:s) n = probe (f c) s (n+#1#)+  probe (Look f)       s     n = probe (f s) s n+  probe p@(Result _ _) _     n = discard n >> R (p >>=)+  probe (Final r)      _     _ = R (Final r >>=)+  probe _              _     _ = q++  discard 0# = return ()+  discard n  = get >> discard (n-#1#)+#else+R f <++ q =+  do s <- look+     probe (f return) s 0+ where+  probe (Get f)        (c:s) n = probe (f c) s (n+1)+  probe (Look f)       s     n = probe (f s) s n+  probe p@(Result _ _) _     n = discard n >> R (p >>=)+  probe (Final r)      _     _ = R (Final r >>=)+  probe _              _     _ = q++  discard 0 = return ()+  discard n  = get >> discard (n-1)+#endif++#ifndef __NHC__+gather :: ReadP a -> ReadP (String, a)+#else+-- gather :: ReadPN (String->P b) a -> ReadPN (String->P b) (String, a)+#endif+-- ^ Transforms a parser into one that does the same, but+--   in addition returns the exact characters read.+--   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument+--   is built using any occurrences of readS_to_P. +gather (R m) =+  R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))  + where+  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))+  gath _ Fail         = Fail+  gath l (Look f)     = Look (\s -> gath l (f s))+  gath l (Result k p) = k (l []) `mplus` gath l p+  gath _ (Final _)    = error "do not use readS_to_P in gather!"++-- ---------------------------------------------------------------------------+-- Derived operations++satisfy :: (Char -> Bool) -> ReadP Char+-- ^ Consumes and returns the next character, if it satisfies the+--   specified predicate.+satisfy p = do c <- get; if p c then return c else pfail++char :: Char -> ReadP Char+-- ^ Parses and returns the specified character.+char c = satisfy (c ==)++string :: String -> ReadP String+-- ^ Parses and returns the specified string.+string this = do s <- look; scan this s+ where+  scan []     _               = do return this+  scan (x:xs) (y:ys) | x == y = do get; scan xs ys+  scan _      _               = do pfail++munch :: (Char -> Bool) -> ReadP String+-- ^ Parses the first zero or more characters satisfying the predicate.+munch p =+  do s <- look+     scan s+ where+  scan (c:cs) | p c = do get; s <- scan cs; return (c:s)+  scan _            = do return ""++munch1 :: (Char -> Bool) -> ReadP String+-- ^ Parses the first one or more characters satisfying the predicate.+munch1 p =+  do c <- get+     if p c then do s <- munch p; return (c:s) else pfail++choice :: [ReadP a] -> ReadP a+-- ^ Combines all parsers in the specified list.+choice []     = pfail+choice [p]    = p+choice (p:ps) = p +++ choice ps++skipSpaces :: ReadP ()+-- ^ Skips all whitespace.+skipSpaces =+  do s <- look+     skip s+ where+  skip (c:s) | isSpace c = do get; skip s+  skip _                 = do return ()++count :: Int -> ReadP a -> ReadP [a]+-- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of+--   results is returned.+count n p = sequence (replicate n p)++between :: ReadP open -> ReadP close -> ReadP a -> ReadP a+-- ^ @between open close p@ parses @open@, followed by @p@ and finally+--   @close@. Only the value of @p@ is returned.+between open close p = do open+                          x <- p+                          close+                          return x++option :: a -> ReadP a -> ReadP a+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming+--   any input.+option x p = p +++ return x++optional :: ReadP a -> ReadP ()+-- ^ @optional p@ optionally parses @p@ and always returns @()@.+optional p = (p >> return ()) +++ return ()++many :: ReadP a -> ReadP [a]+-- ^ Parses zero or more occurrences of the given parser.+many p = return [] +++ many1 p++many1 :: ReadP a -> ReadP [a]+-- ^ Parses one or more occurrences of the given parser.+many1 p = liftM2 (:) p (many p)++skipMany :: ReadP a -> ReadP ()+-- ^ Like 'many', but discards the result.+skipMany p = many p >> return ()++skipMany1 :: ReadP a -> ReadP ()+-- ^ Like 'many1', but discards the result.+skipMany1 p = p >> skipMany p++sepBy :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.+--   Returns a list of values returned by @p@.+sepBy p sep = sepBy1 p sep +++ return []++sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.+--   Returns a list of values returned by @p@.+sepBy1 p sep = liftM2 (:) p (many (sep >> p))++endBy :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended+--   by @sep@.+endBy p sep = many (do x <- p ; sep ; return x)++endBy1 :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended+--   by @sep@.+endBy1 p sep = many1 (do x <- p ; sep ; return x)++chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+--   Returns a value produced by a /right/ associative application of all+--   functions returned by @op@. If there are no occurrences of @p@, @x@ is+--   returned.+chainr p op x = chainr1 p op +++ return x++chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.+--   Returns a value produced by a /left/ associative application of all+--   functions returned by @op@. If there are no occurrences of @p@, @x@ is+--   returned.+chainl p op x = chainl1 p op +++ return x++chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+-- ^ Like 'chainr', but parses one or more occurrences of @p@.+chainr1 p op = scan+  where scan   = p >>= rest+        rest x = do f <- op+                    y <- scan+                    return (f x y)+                 +++ return x++chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+-- ^ Like 'chainl', but parses one or more occurrences of @p@.+chainl1 p op = p >>= rest+  where rest x = do f <- op+                    y <- p+                    rest (f x y)+                 +++ return x++#ifndef __NHC__+manyTill :: ReadP a -> ReadP end -> ReadP [a]+#else+manyTill :: ReadPN [a] a -> ReadPN [a] end -> ReadPN [a] [a]+#endif+-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@+--   succeeds. Returns a list of values returned by @p@.+manyTill p end = scan+  where scan = (end >> return []) <++ (liftM2 (:) p scan)++-- ---------------------------------------------------------------------------+-- Converting between ReadP and Read++#ifndef __NHC__+readP_to_S :: ReadP a -> ReadS a+#else+readP_to_S :: ReadPN a a -> ReadS a+#endif+-- ^ Converts a parser into a Haskell ReadS-style function.+--   This is the main way in which you can \"run\" a 'ReadP' parser:+--   the expanded type is+-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @+readP_to_S (R f) = run (f return)++readS_to_P :: ReadS a -> ReadP a+-- ^ Converts a Haskell ReadS-style function into a parser.+--   Warning: This introduces local backtracking in the resulting+--   parser, and therefore a possible inefficiency.+readS_to_P r =+  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))++-- ---------------------------------------------------------------------------+-- QuickCheck properties that hold for the combinators++{- $properties+The following are QuickCheck specifications of what the combinators do.+These can be seen as formal specifications of the behavior of the+combinators.++We use bags to give semantics to the combinators.++>  type Bag a = [a]++Equality on bags does not care about the order of elements.++>  (=~) :: Ord a => Bag a -> Bag a -> Bool+>  xs =~ ys = sort xs == sort ys++A special equality operator to avoid unresolved overloading+when testing the properties.++>  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool+>  (=~.) = (=~)++Here follow the properties:++>  prop_Get_Nil =+>    readP_to_S get [] =~ []+>+>  prop_Get_Cons c s =+>    readP_to_S get (c:s) =~ [(c,s)]+>+>  prop_Look s =+>    readP_to_S look s =~ [(s,s)]+>+>  prop_Fail s =+>    readP_to_S pfail s =~. []+>+>  prop_Return x s =+>    readP_to_S (return x) s =~. [(x,s)]+>+>  prop_Bind p k s =+>    readP_to_S (p >>= k) s =~.+>      [ ys''+>      | (x,s') <- readP_to_S p s+>      , ys''   <- readP_to_S (k (x::Int)) s'+>      ]+>+>  prop_Plus p q s =+>    readP_to_S (p +++ q) s =~.+>      (readP_to_S p s ++ readP_to_S q s)+>+>  prop_LeftPlus p q s =+>    readP_to_S (p <++ q) s =~.+>      (readP_to_S p s +<+ readP_to_S q s)+>   where+>    [] +<+ ys = ys+>    xs +<+ _  = xs+>+>  prop_Gather s =+>    forAll readPWithoutReadS $ \p -> +>      readP_to_S (gather p) s =~+>	 [ ((pre,x::Int),s')+>	 | (x,s') <- readP_to_S p s+>	 , let pre = take (length s - length s') s+>	 ]+>+>  prop_String_Yes this s =+>    readP_to_S (string this) (this ++ s) =~+>      [(this,s)]+>+>  prop_String_Maybe this s =+>    readP_to_S (string this) s =~+>      [(this, drop (length this) s) | this `isPrefixOf` s]+>+>  prop_Munch p s =+>    readP_to_S (munch p) s =~+>      [(takeWhile p s, dropWhile p s)]+>+>  prop_Munch1 p s =+>    readP_to_S (munch1 p) s =~+>      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]+>+>  prop_Choice ps s =+>    readP_to_S (choice ps) s =~.+>      readP_to_S (foldr (+++) pfail ps) s+>+>  prop_ReadS r s =+>    readP_to_S (readS_to_P r) s =~. r s+-}
+ lib/base/src/Text/ParserCombinators/ReadPrec.hs view
@@ -0,0 +1,162 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.ReadPrec+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)+--+-- This library defines parser combinators for precedence parsing.++-----------------------------------------------------------------------------++module Text.ParserCombinators.ReadPrec+  ( +  ReadPrec,      -- :: * -> *; instance Functor, Monad, MonadPlus+  +  -- * Precedences+  Prec,          -- :: *; = Int+  minPrec,       -- :: Prec; = 0++  -- * Precedence operations+  lift,          -- :: ReadP a -> ReadPrec a+  prec,          -- :: Prec -> ReadPrec a -> ReadPrec a+  step,          -- :: ReadPrec a -> ReadPrec a+  reset,         -- :: ReadPrec a -> ReadPrec a++  -- * Other operations+  -- | All are based directly on their similarly-named 'ReadP' counterparts.+  get,           -- :: ReadPrec Char+  look,          -- :: ReadPrec String+  (+++),         -- :: ReadPrec a -> ReadPrec a -> ReadPrec a+  (<++),         -- :: ReadPrec a -> ReadPrec a -> ReadPrec a+  pfail,         -- :: ReadPrec a+  choice,        -- :: [ReadPrec a] -> ReadPrec a++  -- * Converters+  readPrec_to_P, -- :: ReadPrec a       -> (Int -> ReadP a)+  readP_to_Prec, -- :: (Int -> ReadP a) -> ReadPrec a+  readPrec_to_S, -- :: ReadPrec a       -> (Int -> ReadS a)+  readS_to_Prec, -- :: (Int -> ReadS a) -> ReadPrec a+  )+ where+++import Text.ParserCombinators.ReadP+  ( ReadP+  , ReadS+  , readP_to_S+  , readS_to_P+  )++import qualified Text.ParserCombinators.ReadP as ReadP+  ( get+  , look+  , (+++), (<++)+  , pfail+  )++import Control.Monad( MonadPlus(..) )+#ifdef __GLASGOW_HASKELL__+import GHC.Num( Num(..) )+import GHC.Base+#endif++-- ---------------------------------------------------------------------------+-- The readPrec type++newtype ReadPrec a = P (Prec -> ReadP a)++-- Functor, Monad, MonadPlus++instance Functor ReadPrec where+  fmap h (P f) = P (\n -> fmap h (f n))++instance Monad ReadPrec where+  return x  = P (\_ -> return x)+  fail s    = P (\_ -> fail s)+  P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)+  +instance MonadPlus ReadPrec where+  mzero = pfail+  mplus = (+++)++-- precedences+  +type Prec = Int++minPrec :: Prec+minPrec = 0++-- ---------------------------------------------------------------------------+-- Operations over ReadPrec++lift :: ReadP a -> ReadPrec a+-- ^ Lift a precedence-insensitive 'ReadP' to a 'ReadPrec'.+lift m = P (\_ -> m)++step :: ReadPrec a -> ReadPrec a+-- ^ Increases the precedence context by one.+step (P f) = P (\n -> f (n+1))++reset :: ReadPrec a -> ReadPrec a+-- ^ Resets the precedence context to zero.+reset (P f) = P (\_ -> f minPrec)++prec :: Prec -> ReadPrec a -> ReadPrec a+-- ^ @(prec n p)@ checks whether the precedence context is +--   less than or equal to @n@, and+--+--   * if not, fails+--+--   * if so, parses @p@ in context @n@.+prec n (P f) = P (\c -> if c <= n then f n else ReadP.pfail)++-- ---------------------------------------------------------------------------+-- Derived operations++get :: ReadPrec Char+-- ^ Consumes and returns the next character.+--   Fails if there is no input left.+get = lift ReadP.get++look :: ReadPrec String+-- ^ Look-ahead: returns the part of the input that is left, without+--   consuming it.+look = lift ReadP.look++(+++) :: ReadPrec a -> ReadPrec a -> ReadPrec a+-- ^ Symmetric choice.+P f1 +++ P f2 = P (\n -> f1 n ReadP.+++ f2 n)++(<++) :: ReadPrec a -> ReadPrec a -> ReadPrec a+-- ^ Local, exclusive, left-biased choice: If left parser+--   locally produces any result at all, then right parser is+--   not used.+P f1 <++ P f2 = P (\n -> f1 n ReadP.<++ f2 n)++pfail :: ReadPrec a+-- ^ Always fails.+pfail = lift ReadP.pfail++choice :: [ReadPrec a] -> ReadPrec a+-- ^ Combines all parsers in the specified list.+choice ps = foldr (+++) pfail ps++-- ---------------------------------------------------------------------------+-- Converting between ReadPrec and Read++readPrec_to_P :: ReadPrec a -> (Int -> ReadP a)+readPrec_to_P (P f) = f++readP_to_Prec :: (Int -> ReadP a) -> ReadPrec a+readP_to_Prec f = P f++readPrec_to_S :: ReadPrec a -> (Int -> ReadS a)+readPrec_to_S (P f) n = readP_to_S (f n)++readS_to_Prec :: (Int -> ReadS a) -> ReadPrec a+readS_to_Prec f = P (\n -> readS_to_P (f n))
lib/base/src/Text/Printf.hs view
@@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.Printf--- Copyright   :  (c) Lennart Augustsson, 2004+-- Copyright   :  (c) Lennart Augustsson, 2004-2008 -- License     :  BSD-style (see the file libraries/base/LICENSE)---+--  -- Maintainer  :  lennart@augustsson.net -- Stability   :  provisional -- Portability :  portable@@ -19,6 +19,8 @@  import Prelude import Data.Char+import Data.Int+import Data.Word import Numeric(showEFloat, showFFloat, showGFloat) import System.IO @@ -33,10 +35,11 @@ -- character @%@, followed by one or more of the following flags: -- -- >    -      left adjust (default is right adjust)+-- >    +      always use a sign (+ or -) for signed conversions -- >    0      pad with zeroes rather than spaces -- -- followed optionally by a field width:---+--  -- >    num    field width -- >    *      as num, but taken from argument list --@@ -46,14 +49,17 @@ -- -- 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+-- >    c      character               Char, Int, Integer, ...+-- >    d      decimal                 Char, Int, Integer, ...+-- >    o      octal                   Char, Int, Integer, ...+-- >    x      hexadecimal             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+-- >    G      general format float    Float, Double -- >    e      exponent format float   Float, Double+-- >    E      exponent format float   Float, Double -- >    s      string                  String -- -- Mismatch between the argument types and the format string will cause@@ -69,12 +75,12 @@ -- >   3.14 -- printf :: (PrintfType r) => String -> r-printf fmt = spr fmt []+printf fmts = spr fmts []  -- | 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 []+hPrintf hdl fmts = hspr hdl fmts []  -- |The 'PrintfType' class provides the variable argument magic for -- 'printf'.  Its implementation is intentionally not visible from@@ -95,23 +101,23 @@     spr fmt args = uprintf fmt (reverse args) -} instance (IsChar c) => PrintfType [c] where-    spr fmt args = map fromChar (uprintf fmt (reverse args))+    spr fmts args = map fromChar (uprintf fmts (reverse args))  instance PrintfType (IO a) where-    spr fmt args = do-	putStr (uprintf fmt (reverse args))+    spr fmts args = do+	putStr (uprintf fmts (reverse args)) 	return undefined  instance HPrintfType (IO a) where-    hspr hdl fmt args = do-	hPutStr hdl (uprintf fmt (reverse args))+    hspr hdl fmts args = do+	hPutStr hdl (uprintf fmts (reverse args)) 	return undefined  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where-    spr fmt args = \ a -> spr fmt (toUPrintf a : args)+    spr fmts args = \ a -> spr fmts (toUPrintf a : args)  instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where-    hspr hdl fmt args = \ a -> hspr hdl fmt (toUPrintf a : args)+    hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)  class PrintfArg a where     toUPrintf :: a -> UPrintf@@ -124,20 +130,52 @@     toUPrintf s = UString s -} instance (IsChar c) => PrintfArg [c] where-    toUPrintf s = UString (map toChar s)+    toUPrintf = UString . map toChar  instance PrintfArg Int where-    toUPrintf i = UInt i+    toUPrintf = uInteger +instance PrintfArg Int8 where+    toUPrintf = uInteger++instance PrintfArg Int16 where+    toUPrintf = uInteger++instance PrintfArg Int32 where+    toUPrintf = uInteger++instance PrintfArg Int64 where+    toUPrintf = uInteger++#ifndef __NHC__+instance PrintfArg Word where+    toUPrintf = uInteger+#endif++instance PrintfArg Word8 where+    toUPrintf = uInteger++instance PrintfArg Word16 where+    toUPrintf = uInteger++instance PrintfArg Word32 where+    toUPrintf = uInteger++instance PrintfArg Word64 where+    toUPrintf = uInteger+ instance PrintfArg Integer where-    toUPrintf i = UInteger i+    toUPrintf = UInteger 0  instance PrintfArg Float where-    toUPrintf f = UFloat f+    toUPrintf = UFloat  instance PrintfArg Double where-    toUPrintf d = UDouble d+    toUPrintf = UDouble +uInteger :: (Integral a, Bounded a) => a -> UPrintf+uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)+ class IsChar c where     toChar :: c -> Char     fromChar :: Char -> c@@ -148,7 +186,7 @@  ------------------- -data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double+data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double  uprintf :: String -> [UPrintf] -> String uprintf ""       []       = ""@@ -160,12 +198,14 @@  fmt :: String -> [UPrintf] -> String fmt cs us =-	let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us-	    adjust (pre, str) =+	let (width, prec, ladj, zero, plus, cs', us') = getSpecs False 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+            adjust' ("", str) | plus = adjust ("+", str)+            adjust' ps = adjust ps         in 	case cs' of 	[]     -> fmterr@@ -174,103 +214,109 @@ 	    []     -> 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])+		'c' -> adjust  ("", [toEnum (toint u)])+		'd' -> adjust' (fmti u)+		'i' -> adjust' (fmti u)+		'x' -> adjust  ("", fmtu 16 u)+		'X' -> adjust  ("", map toUpper $ fmtu 16 u)+		'o' -> adjust  ("", fmtu 8  u)+		'u' -> adjust  ("", fmtu 10 u)+		'e' -> adjust' (dfmt' c prec u)+		'E' -> adjust' (dfmt' c prec u)+		'f' -> adjust' (dfmt' c prec u)+		'g' -> adjust' (dfmt' c prec u)+		'G' -> adjust' (dfmt' c prec u)+		's' -> adjust  ("", tostr prec u)+		_   -> 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+fmti :: UPrintf -> (String, String)+fmti (UInteger _ i) = if i < 0 then ("-", show (-i)) else ("", show i)+fmti (UChar c)      = fmti (uInteger (fromEnum c))+fmti _		    = baderr -toint (UInt i)     = i-toint (UInteger i) = toInt i-toint (UChar c)    = fromEnum c-toint u		   = baderr+fmtu :: Integer -> UPrintf -> String+fmtu b (UInteger l i) = itosb b (if i < 0 then -2*l + i else i)+fmtu b (UChar c)      = itosb b (toInteger (fromEnum c))+fmtu _ _              = baderr -tostr (UString s) = s-tostr u		  = baderr+toint :: UPrintf -> Int+toint (UInteger _ i) = fromInteger i+toint (UChar c)      = fromEnum c+toint _		     = 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)]+tostr :: Int -> UPrintf -> String+tostr n (UString s) = if n >= 0 then take n s else s+tostr _ _		  = baderr  itosb :: Integer -> Integer -> String-itosb b n =-	if n < b then+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 (c:cs) | isDigit c = stoi (a*10 + digitToInt c) 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'') =+getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])+getSpecs _ z s ('-':cs) us = getSpecs True z s cs us+getSpecs l z _ ('+':cs) us = getSpecs l z True cs us+getSpecs l _ s ('0':cs) us = getSpecs l True s cs us+getSpecs l z s ('*':cs) us =+	let (us', n) = getStar us+	    ((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 =+                    '.':'*':r -> let (us''', p') = getStar us'+		    	      	 in  ((p', r), us''')+		    '.':r     -> (stoi 0 r, us')+		    _         -> ((-1, cs), us')+	in  (n, p, l, z, s, cs'', us'')+getSpecs l z s ('.':cs) us =+	let ((p, cs'), us') = +	        case cs of+		'*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')+                _ ->        (stoi 0 cs, us)+	in  (0, p, l, z, s, cs', us')+getSpecs l z s 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)+	    ((p, cs''), us') = case cs' of+	    	 	       '.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')+		               '.':r -> (stoi 0 r, us)+			       _     -> ((-1, cs'), us)+	in  (n, p, l, z, s, cs'', us')+getSpecs l z s cs       us = (0, -1, l, z, s, cs, us) +getStar :: [UPrintf] -> ([UPrintf], Int)+getStar us =+    case us of+    [] -> argerr+    nu : us' -> (us', toint nu)+++dfmt' :: Char -> Int -> UPrintf -> (String, String) dfmt' c p (UDouble d) = dfmt c p d dfmt' c p (UFloat f)  = dfmt c p f-dfmt' c p u           = baderr+dfmt' _ _ _           = baderr +dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String) dfmt c p d =-	case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat)+	case (if isUpper c then map toUpper else id) $+             (case toLower c of+                  'e' -> showEFloat+                  'f' -> showFFloat+                  'g' -> showGFloat+                  _   -> error "Printf.dfmt: impossible"+             )                (if p < 0 then Nothing else Just p) d "" of 	'-':cs -> ("-", cs) 	cs     -> ("" , cs) +perror :: String -> a perror s = error ("Printf.printf: "++s)+fmterr, argerr, baderr :: a 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/base/src/Text/Read.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Read+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)+--+-- Converting strings to values.+--+-- The "Text.Read" library is the canonical library to import for+-- 'Read'-class facilities.  For GHC only, it offers an extended and much+-- improved 'Read' class, which constitutes a proposed alternative to the +-- Haskell 98 'Read'.  In particular, writing parsers is easier, and+-- the parsers are much more efficient.+--+-----------------------------------------------------------------------------++module Text.Read (+   -- * The 'Read' class+   Read(..),            -- The Read class+   ReadS,               -- String -> Maybe (a,String)++   -- * Haskell 98 functions+   reads,               -- :: (Read a) => ReadS a+   read,                -- :: (Read a) => String -> a+   readParen,           -- :: Bool -> ReadS a -> ReadS a+   lex,                 -- :: ReadS String++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+   -- * New parsing functions+   module Text.ParserCombinators.ReadPrec,+   L.Lexeme(..),+   lexP,                -- :: ReadPrec Lexeme+   parens,              -- :: ReadPrec a -> ReadPrec a+#endif+#ifdef __GLASGOW_HASKELL__+   readListDefault,     -- :: Read a => ReadS [a]+   readListPrecDefault, -- :: Read a => ReadPrec [a]+#endif++ ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Read+import Data.Either+import Text.ParserCombinators.ReadP as P+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+import Text.ParserCombinators.ReadPrec+import qualified Text.Read.Lex as L+#endif++#ifdef __HUGS__+-- copied from GHC.Read++lexP :: ReadPrec L.Lexeme+lexP = lift L.lex++parens :: ReadPrec a -> ReadPrec a+parens p = optional+ where+  optional  = p +++ mandatory+  mandatory = do+    L.Punc "(" <- lexP+    x          <- reset optional+    L.Punc ")" <- lexP+    return x+#endif++#ifdef __GLASGOW_HASKELL__+------------------------------------------------------------------------+-- utility functions++-- | equivalent to 'readsPrec' with a precedence of 0.+reads :: Read a => ReadS a+reads = readsPrec minPrec++readEither :: Read a => String -> Either String a+readEither s =+  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of+    [x] -> Right x+    []  -> Left "Prelude.read: no parse"+    _   -> Left "Prelude.read: ambiguous parse"+ where+  read' =+    do x <- readPrec+       lift P.skipSpaces+       return x++-- | The 'read' function reads input from a string, which must be+-- completely consumed by the input process.+read :: Read a => String -> a+read s = either error id (readEither s)+#endif+
+ lib/base/src/Text/Read/Lex.hs view
@@ -0,0 +1,445 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Read.Lex+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)+--+-- The cut-down Haskell lexer, used by Text.Read+--+-----------------------------------------------------------------------------++module Text.Read.Lex+  -- lexing types+  ( Lexeme(..)  -- :: *; Show, Eq++  -- lexer      +  , lex         -- :: ReadP Lexeme      Skips leading spaces+  , hsLex       -- :: ReadP String+  , lexChar     -- :: ReadP Char        Reads just one char, with H98 escapes++  , readIntP    -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a+  , readOctP    -- :: Num a => ReadP a +  , readDecP    -- :: Num a => ReadP a+  , readHexP    -- :: Num a => ReadP a+  )+ where++import Text.ParserCombinators.ReadP++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Num( Num(..), Integer )+import GHC.Show( Show(..) )+#ifndef __HADDOCK__+import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )+#endif+import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral, +                 toInteger, (^), (^^), infinity, notANumber )+import GHC.List+import GHC.Enum( maxBound )+#else+import Prelude hiding ( lex )+import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )+import Data.Ratio( Ratio, (%) )+#endif+#ifdef __HUGS__+import Hugs.Prelude( Ratio(..) )+#endif+import Data.Maybe+import Control.Monad++-- -----------------------------------------------------------------------------+-- Lexing types++-- ^ Haskell lexemes.+data Lexeme+  = Char   Char         -- ^ Character literal+  | String String       -- ^ String literal, with escapes interpreted+  | Punc   String       -- ^ Punctuation or reserved symbol, e.g. @(@, @::@+  | Ident  String       -- ^ Haskell identifier, e.g. @foo@, @Baz@+  | Symbol String       -- ^ Haskell symbol, e.g. @>>@, @:%@+  | Int Integer         -- ^ Integer literal+  | Rat Rational        -- ^ Floating point literal+  | EOF+ deriving (Eq, Show)++-- -----------------------------------------------------------------------------+-- Lexing++lex :: ReadP Lexeme+lex = skipSpaces >> lexToken++hsLex :: ReadP String+-- ^ Haskell lexer: returns the lexed string, rather than the lexeme+hsLex = do skipSpaces +           (s,_) <- gather lexToken+           return s++lexToken :: ReadP Lexeme+lexToken = lexEOF     ++++           lexLitChar +++ +           lexString  +++ +           lexPunc    +++ +           lexSymbol  +++ +           lexId      +++ +           lexNumber+++-- ----------------------------------------------------------------------+-- End of file+lexEOF :: ReadP Lexeme+lexEOF = do s <- look+            guard (null s)+            return EOF++-- ---------------------------------------------------------------------------+-- Single character lexemes++lexPunc :: ReadP Lexeme+lexPunc =+  do c <- satisfy isPuncChar+     return (Punc [c])+ where+  isPuncChar c = c `elem` ",;()[]{}`"++-- ----------------------------------------------------------------------+-- Symbols++lexSymbol :: ReadP Lexeme+lexSymbol =+  do s <- munch1 isSymbolChar+     if s `elem` reserved_ops then +        return (Punc s)         -- Reserved-ops count as punctuation+      else+        return (Symbol s)+ where+  isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"+  reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]++-- ----------------------------------------------------------------------+-- identifiers++lexId :: ReadP Lexeme+lexId = lex_nan <++ lex_id+  where+        -- NaN and Infinity look like identifiers, so+        -- we parse them first.  +    lex_nan = (string "NaN"      >> return (Rat notANumber)) ++++              (string "Infinity" >> return (Rat infinity))+  +    lex_id = do c <- satisfy isIdsChar+                s <- munch isIdfChar+                return (Ident (c:s))++          -- Identifiers can start with a '_'+    isIdsChar c = isAlpha c || c == '_'+    isIdfChar c = isAlphaNum c || c `elem` "_'"++#ifndef __GLASGOW_HASKELL__+infinity, notANumber :: Rational+infinity   = 1 :% 0+notANumber = 0 :% 0+#endif++-- ---------------------------------------------------------------------------+-- Lexing character literals++lexLitChar :: ReadP Lexeme+lexLitChar =+  do char '\''+     (c,esc) <- lexCharE+     guard (esc || c /= '\'')   -- Eliminate '' possibility+     char '\''+     return (Char c)++lexChar :: ReadP Char+lexChar = do { (c,_) <- lexCharE; return c }++lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?+lexCharE =+  do c1 <- get+     if c1 == '\\'+       then do c2 <- lexEsc; return (c2, True)+       else do return (c1, False)+ where +  lexEsc =+    lexEscChar+      +++ lexNumeric+        +++ lexCntrlChar+          +++ lexAscii+  +  lexEscChar =+    do c <- get+       case c of+         'a'  -> return '\a'+         'b'  -> return '\b'+         'f'  -> return '\f'+         'n'  -> return '\n'+         'r'  -> return '\r'+         't'  -> return '\t'+         'v'  -> return '\v'+         '\\' -> return '\\'+         '\"' -> return '\"'+         '\'' -> return '\''+         _    -> pfail+  +  lexNumeric =+    do base <- lexBaseChar <++ return 10+       n    <- lexInteger base+       guard (n <= toInteger (ord maxBound))+       return (chr (fromInteger n))++  lexCntrlChar =+    do char '^'+       c <- get+       case c of+         '@'  -> return '\^@'+         'A'  -> return '\^A'+         'B'  -> return '\^B'+         'C'  -> return '\^C'+         'D'  -> return '\^D'+         'E'  -> return '\^E'+         'F'  -> return '\^F'+         'G'  -> return '\^G'+         'H'  -> return '\^H'+         'I'  -> return '\^I'+         'J'  -> return '\^J'+         'K'  -> return '\^K'+         'L'  -> return '\^L'+         'M'  -> return '\^M'+         'N'  -> return '\^N'+         'O'  -> return '\^O'+         'P'  -> return '\^P'+         'Q'  -> return '\^Q'+         'R'  -> return '\^R'+         'S'  -> return '\^S'+         'T'  -> return '\^T'+         'U'  -> return '\^U'+         'V'  -> return '\^V'+         'W'  -> return '\^W'+         'X'  -> return '\^X'+         'Y'  -> return '\^Y'+         'Z'  -> return '\^Z'+         '['  -> return '\^['+         '\\' -> return '\^\'+         ']'  -> return '\^]'+         '^'  -> return '\^^'+         '_'  -> return '\^_'+         _    -> pfail++  lexAscii =+    do choice+         [ (string "SOH" >> return '\SOH') <+++           (string "SO"  >> return '\SO') +                -- \SO and \SOH need maximal-munch treatment+                -- See the Haskell report Sect 2.6++         , string "NUL" >> return '\NUL'+         , string "STX" >> return '\STX'+         , string "ETX" >> return '\ETX'+         , string "EOT" >> return '\EOT'+         , string "ENQ" >> return '\ENQ'+         , string "ACK" >> return '\ACK'+         , string "BEL" >> return '\BEL'+         , string "BS"  >> return '\BS'+         , string "HT"  >> return '\HT'+         , string "LF"  >> return '\LF'+         , string "VT"  >> return '\VT'+         , string "FF"  >> return '\FF'+         , string "CR"  >> return '\CR'+         , string "SI"  >> return '\SI'+         , string "DLE" >> return '\DLE'+         , string "DC1" >> return '\DC1'+         , string "DC2" >> return '\DC2'+         , string "DC3" >> return '\DC3'+         , string "DC4" >> return '\DC4'+         , string "NAK" >> return '\NAK'+         , string "SYN" >> return '\SYN'+         , string "ETB" >> return '\ETB'+         , string "CAN" >> return '\CAN'+         , string "EM"  >> return '\EM'+         , string "SUB" >> return '\SUB'+         , string "ESC" >> return '\ESC'+         , string "FS"  >> return '\FS'+         , string "GS"  >> return '\GS'+         , string "RS"  >> return '\RS'+         , string "US"  >> return '\US'+         , string "SP"  >> return '\SP'+         , string "DEL" >> return '\DEL'+         ]+++-- ---------------------------------------------------------------------------+-- string literal++lexString :: ReadP Lexeme+lexString =+  do char '"'+     body id+ where+  body f =+    do (c,esc) <- lexStrItem+       if c /= '"' || esc+         then body (f.(c:))+         else let s = f "" in+              return (String s)++  lexStrItem = (lexEmpty >> lexStrItem)+               +++ lexCharE+  +  lexEmpty =+    do char '\\'+       c <- get+       case c of+         '&'           -> do return ()+         _ | isSpace c -> do skipSpaces; char '\\'; return ()+         _             -> do pfail++-- ---------------------------------------------------------------------------+--  Lexing numbers++type Base   = Int+type Digits = [Int]++lexNumber :: ReadP Lexeme+lexNumber +  = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc+                        -- If that fails, try for a decimal number+    lexDecNumber        -- Start with ordinary digits+                +lexHexOct :: ReadP Lexeme+lexHexOct+  = do  char '0'+        base <- lexBaseChar+        digits <- lexDigits base+        return (Int (val (fromIntegral base) 0 digits))++lexBaseChar :: ReadP Int+-- Lex a single character indicating the base; fail if not there+lexBaseChar = do { c <- get;+                   case c of+                        'o' -> return 8+                        'O' -> return 8+                        'x' -> return 16+                        'X' -> return 16+                        _   -> pfail } ++lexDecNumber :: ReadP Lexeme+lexDecNumber =+  do xs    <- lexDigits 10+     mFrac <- lexFrac <++ return Nothing+     mExp  <- lexExp  <++ return Nothing+     return (value xs mFrac mExp)+ where+  value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp+  +  valueFracExp :: Integer -> Maybe Digits -> Maybe Integer +               -> Lexeme+  valueFracExp a Nothing Nothing        +    = Int a                                             -- 43+  valueFracExp a Nothing (Just exp)+    | exp >= 0  = Int (a * (10 ^ exp))                  -- 43e7+    | otherwise = Rat (valExp (fromInteger a) exp)      -- 43e-7+  valueFracExp a (Just fs) mExp +     = case mExp of+         Nothing  -> Rat rat                            -- 4.3+         Just exp -> Rat (valExp rat exp)               -- 4.3e-4+     where+        rat :: Rational+        rat = fromInteger a + frac 10 0 1 fs++  valExp :: Rational -> Integer -> Rational+  valExp rat exp = rat * (10 ^^ exp)++lexFrac :: ReadP (Maybe Digits)+-- Read the fractional part; fail if it doesn't+-- start ".d" where d is a digit+lexFrac = do char '.'+             fraction <- lexDigits 10+             return (Just fraction)++lexExp :: ReadP (Maybe Integer)+lexExp = do char 'e' +++ char 'E'+            exp <- signedExp +++ lexInteger 10+            return (Just exp)+ where+   signedExp +     = do c <- char '-' +++ char '+'+          n <- lexInteger 10+          return (if c == '-' then -n else n)++lexDigits :: Int -> ReadP Digits+-- Lex a non-empty sequence of digits in specified base+lexDigits base =+  do s  <- look+     xs <- scan s id+     guard (not (null xs))+     return xs+ where+  scan (c:cs) f = case valDig base c of+                    Just n  -> do get; scan cs (f.(n:))+                    Nothing -> do return (f [])+  scan []     f = do return (f [])++lexInteger :: Base -> ReadP Integer+lexInteger base =+  do xs <- lexDigits base+     return (val (fromIntegral base) 0 xs)++val :: Num a => a -> a -> Digits -> a+-- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were+val _    y []     = y+val base y (x:xs) = y' `seq` val base y' xs+ where+  y' = y * base + fromIntegral x++frac :: Integral a => a -> a -> a -> Digits -> Ratio a+frac _    a b []     = a % b+frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs+ where+  a' = a * base + fromIntegral x+  b' = b * base++valDig :: Num a => a -> Char -> Maybe Int+valDig 8 c+  | '0' <= c && c <= '7' = Just (ord c - ord '0')+  | otherwise            = Nothing++valDig 10 c = valDecDig c++valDig 16 c+  | '0' <= c && c <= '9' = Just (ord c - ord '0')+  | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)+  | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)+  | otherwise            = Nothing++valDig _ _ = error "valDig: Bad base"++valDecDig :: Char -> Maybe Int+valDecDig c+  | '0' <= c && c <= '9' = Just (ord c - ord '0')+  | otherwise            = Nothing++-- ----------------------------------------------------------------------+-- other numeric lexing functions++readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a+readIntP base isDigit valDigit =+  do s <- munch1 isDigit+     return (val base 0 (map valDigit s))++readIntP' :: Num a => a -> ReadP a+readIntP' base = readIntP base isDigit valDigit+ where+  isDigit  c = maybe False (const True) (valDig base c)+  valDigit c = maybe 0     id           (valDig base c)++readOctP, readDecP, readHexP :: Num a => ReadP a+readOctP = readIntP' 8+readDecP = readIntP' 10+readHexP = readIntP' 16
+ lib/base/src/Text/Show.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Show+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Converting values to readable strings:+-- the 'Show' class and associated functions.+--+-----------------------------------------------------------------------------++module Text.Show (+   ShowS,               -- String -> String+   Show(+      showsPrec,        -- :: Int -> a -> ShowS+      show,             -- :: a   -> String+      showList          -- :: [a] -> ShowS +    ),+   shows,               -- :: (Show a) => a -> ShowS+   showChar,            -- :: Char -> ShowS+   showString,          -- :: String -> ShowS+   showParen,           -- :: Bool -> ShowS -> ShowS+   showListWith,        -- :: (a -> ShowS) -> [a] -> ShowS + ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Show+#endif++-- | Show a list (using square brackets and commas), given a function+-- for showing elements.+showListWith :: (a -> ShowS) -> [a] -> ShowS+showListWith = showList__++#ifndef __GLASGOW_HASKELL__+showList__ :: (a -> ShowS) ->  [a] -> ShowS+showList__ _     []     s = "[]" ++ s+showList__ showx (x:xs) s = '[' : showx x (showl xs)+  where+    showl []     = ']' : s+    showl (y:ys) = ',' : showx y (showl ys)+#endif
lib/base/src/Text/Show/Functions.hs view
@@ -1,5 +1,34 @@-module Text.Show.Functions where+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Show.Functions+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Optional instance of 'Text.Show.Show' for functions:+--+-- > instance Show (a -> b) where+-- > 	showsPrec _ _ = showString \"\<function\>\"+--+----------------------------------------------------------------------------- +module Text.Show.Functions () where +import Prelude++#ifndef __NHC__ instance Show (a -> b) where-    showsPrec _ _ = showString "<function>"+	showsPrec _ _ = showString "<function>"+#else+instance (Show a,Show b) => Show (a->b) where+  showsPrec d a = showString "<<function>>"++  showsType a = showChar '(' . showsType value  . showString " -> " .+                               showsType result . showChar ')'+                where (value,result) = getTypes undefined+                      getTypes x = (x,a x)+#endif
− lib/base/src/Typeable.hs 
@@ -1,15 +0,0 @@-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/base/src/Unsafe/Coerce.hs view
@@ -1,5 +1,42 @@-{-# OPTIONS_LHC -N -fffi #-}-module Unsafe.Coerce(unsafeCoerce) where+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Unsafe.Coerce+-- Copyright   :  Malcolm Wallace 2006+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The highly unsafe primitive 'unsafeCoerce' converts a value from any+-- type to any other type.  Needless to say, if you use this function,+-- it is your responsibility to ensure that the old and new types have+-- identical internal representations, in order to prevent runtime corruption.+--+-- The types for which 'unsafeCoerce' is representation-safe may differ+-- from compiler to compiler (and version to version).+--+--   * Documentation for correct usage in GHC will be found under+--     'unsafeCoerce#' in GHC.Base (around which 'unsafeCoerce' is just a+--     trivial wrapper).+--+--   * In nhc98, the only representation-safe coercions are between Enum+--     types with the same range (e.g. Int, Int32, Char, Word32),+--     or between a newtype and the type that it wraps. +module Unsafe.Coerce (unsafeCoerce) where -foreign import primitive unsafeCoerce :: a -> b+#if defined(__GLASGOW_HASKELL__)+import GHC.Prim (unsafeCoerce#)+unsafeCoerce :: a -> b+unsafeCoerce = unsafeCoerce#+#endif++#if defined(__NHC__)+import NonStdUnsafeCoerce (unsafeCoerce)+#endif++#if defined(__HUGS__)+import Hugs.IOExts (unsafeCoerce)+#endif
+ lib/ghc-prim/GHC/Bool.hs view
@@ -0,0 +1,11 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Bool (Bool(..)) where++-- We need Inl etc behind the scenes for the Bool definition+import GHC.Generics ()++default ()++data Bool = False | True
+ lib/ghc-prim/GHC/Generics.hs view
@@ -0,0 +1,13 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Generics where++default ()++data Unit = Unit+#ifndef __HADDOCK__+data (:+:) a b = Inl a | Inr b+data (:*:) a b = a :*: b+#endif+
+ lib/ghc-prim/GHC/IntWord32.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.IntWord32+-- Copyright   :  (c) The University of Glasgow, 1997-2008+-- License     :  see libraries/ghc-prim/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Primitive operations on Int32# and Word32# on platforms where+-- WORD_SIZE_IN_BITS < 32.+--+-----------------------------------------------------------------------------++-- include "MachDeps.h"++#define WORD_SIZE_IN_BITS 64++-- #hide+module GHC.IntWord32 (+#if WORD_SIZE_IN_BITS < 32+    Int32#, Word32#, module GHC.IntWord32+#endif+ ) where++#if WORD_SIZE_IN_BITS < 32+import GHC.Bool+import GHC.Prim++foreign import unsafe "stg_eqWord32"      eqWord32#      :: Word32# -> Word32# -> Bool+foreign import unsafe "stg_neWord32"      neWord32#      :: Word32# -> Word32# -> Bool+foreign import unsafe "stg_ltWord32"      ltWord32#      :: Word32# -> Word32# -> Bool+foreign import unsafe "stg_leWord32"      leWord32#      :: Word32# -> Word32# -> Bool+foreign import unsafe "stg_gtWord32"      gtWord32#      :: Word32# -> Word32# -> Bool+foreign import unsafe "stg_geWord32"      geWord32#      :: Word32# -> Word32# -> Bool++foreign import unsafe "stg_eqInt32"       eqInt32#       :: Int32# -> Int32# -> Bool+foreign import unsafe "stg_neInt32"       neInt32#       :: Int32# -> Int32# -> Bool+foreign import unsafe "stg_ltInt32"       ltInt32#       :: Int32# -> Int32# -> Bool+foreign import unsafe "stg_leInt32"       leInt32#       :: Int32# -> Int32# -> Bool+foreign import unsafe "stg_gtInt32"       gtInt32#       :: Int32# -> Int32# -> Bool+foreign import unsafe "stg_geInt32"       geInt32#       :: Int32# -> Int32# -> Bool++foreign import unsafe "stg_int32ToWord32" int32ToWord32# :: Int32# -> Word32#+foreign import unsafe "stg_word32ToInt32" word32ToInt32# :: Word32# -> Int32#+foreign import unsafe "stg_intToInt32"    intToInt32#    :: Int# -> Int32#+foreign import unsafe "stg_wordToWord32"  wordToWord32#  :: Word# -> Word32#+foreign import unsafe "stg_word32ToWord"  word32ToWord#  :: Word32# -> Word#++foreign import unsafe "stg_plusInt32"     plusInt32#     :: Int32# -> Int32# -> Int32#+foreign import unsafe "stg_minusInt32"    minusInt32#    :: Int32# -> Int32# -> Int32#+foreign import unsafe "stg_timesInt32"    timesInt32#    :: Int32# -> Int32# -> Int32#+foreign import unsafe "stg_negateInt32"   negateInt32#   :: Int32# -> Int32#+foreign import unsafe "stg_quotInt32"     quotInt32#     :: Int32# -> Int32# -> Int32#+foreign import unsafe "stg_remInt32"      remInt32#      :: Int32# -> Int32# -> Int32#+foreign import unsafe "stg_quotWord32"    quotWord32#    :: Word32# -> Word32# -> Word32#+foreign import unsafe "stg_remWord32"     remWord32#     :: Word32# -> Word32# -> Word32#++foreign import unsafe "stg_and32"         and32#         :: Word32# -> Word32# -> Word32#+foreign import unsafe "stg_or32"          or32#          :: Word32# -> Word32# -> Word32#+foreign import unsafe "stg_xor32"         xor32#         :: Word32# -> Word32# -> Word32#+foreign import unsafe "stg_not32"         not32#         :: Word32# -> Word32#++foreign import unsafe "stg_iShiftL32"     iShiftL32#     :: Int32# -> Int# -> Int32#+foreign import unsafe "stg_iShiftRA32"    iShiftRA32#    :: Int32# -> Int# -> Int32#+foreign import unsafe "stg_shiftL32"      shiftL32#      :: Word32# -> Int# -> Word32#+foreign import unsafe "stg_shiftRL32"     shiftRL32#     :: Word32# -> Int# -> Word32#++#endif+
+ lib/ghc-prim/GHC/IntWord64.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.IntWord64+-- Copyright   :  (c) The University of Glasgow, 1997-2008+-- License     :  see libraries/ghc-prim/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Primitive operations on Int64# and Word64# on platforms where+-- WORD_SIZE_IN_BITS < 64.+--+-----------------------------------------------------------------------------++-- include "MachDeps.h"++-- #hide+module GHC.IntWord64 (+#if WORD_SIZE_IN_BITS < 64+    Int64#, Word64#, module GHC.IntWord64+#endif+ ) where++#if WORD_SIZE_IN_BITS < 64+import GHC.Bool+import GHC.Prim++foreign import ccall unsafe "hs_eqWord64"    eqWord64#      :: Word64# -> Word64# -> Bool+foreign import ccall unsafe "hs_neWord64"    neWord64#      :: Word64# -> Word64# -> Bool+foreign import ccall unsafe "hs_ltWord64"    ltWord64#      :: Word64# -> Word64# -> Bool+foreign import ccall unsafe "hs_leWord64"    leWord64#      :: Word64# -> Word64# -> Bool+foreign import ccall unsafe "hs_gtWord64"    gtWord64#      :: Word64# -> Word64# -> Bool+foreign import ccall unsafe "hs_geWord64"    geWord64#      :: Word64# -> Word64# -> Bool++foreign import ccall unsafe "hs_eqInt64"     eqInt64#       :: Int64# -> Int64# -> Bool+foreign import ccall unsafe "hs_neInt64"     neInt64#       :: Int64# -> Int64# -> Bool+foreign import ccall unsafe "hs_ltInt64"     ltInt64#       :: Int64# -> Int64# -> Bool+foreign import ccall unsafe "hs_leInt64"     leInt64#       :: Int64# -> Int64# -> Bool+foreign import ccall unsafe "hs_gtInt64"     gtInt64#       :: Int64# -> Int64# -> Bool+foreign import ccall unsafe "hs_geInt64"     geInt64#       :: Int64# -> Int64# -> Bool+foreign import ccall unsafe "hs_quotInt64"   quotInt64#     :: Int64# -> Int64# -> Int64#+foreign import ccall unsafe "hs_remInt64"    remInt64#      :: Int64# -> Int64# -> Int64#++foreign import ccall unsafe "hs_plusInt64"   plusInt64#     :: Int64# -> Int64# -> Int64#+foreign import ccall unsafe "hs_minusInt64"  minusInt64#    :: Int64# -> Int64# -> Int64#+foreign import ccall unsafe "hs_timesInt64"  timesInt64#    :: Int64# -> Int64# -> Int64#+foreign import ccall unsafe "hs_negateInt64" negateInt64#   :: Int64# -> Int64#+foreign import ccall unsafe "hs_quotWord64"  quotWord64#    :: Word64# -> Word64# -> Word64#+foreign import ccall unsafe "hs_remWord64"   remWord64#     :: Word64# -> Word64# -> Word64#++foreign import ccall unsafe "hs_and64"       and64#         :: Word64# -> Word64# -> Word64#+foreign import ccall unsafe "hs_or64"        or64#          :: Word64# -> Word64# -> Word64#+foreign import ccall unsafe "hs_xor64"       xor64#         :: Word64# -> Word64# -> Word64#+foreign import ccall unsafe "hs_not64"       not64#         :: Word64# -> Word64#++foreign import ccall unsafe "hs_uncheckedShiftL64"   uncheckedShiftL64#   :: Word64# -> Int# -> Word64#+foreign import ccall unsafe "hs_uncheckedShiftRL64"  uncheckedShiftRL64#  :: Word64# -> Int# -> Word64#+foreign import ccall unsafe "hs_uncheckedIShiftL64"  uncheckedIShiftL64#  :: Int64# -> Int# -> Int64#+foreign import ccall unsafe "hs_uncheckedIShiftRA64" uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#+foreign import ccall unsafe "hs_uncheckedIShiftRL64" uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#++foreign import ccall unsafe "hs_integerToWord64" integerToWord64# :: Int# -> ByteArray# -> Word64#+foreign import ccall unsafe "hs_integerToInt64"  integerToInt64#  :: Int# -> ByteArray# -> Int64#+foreign import ccall unsafe "hs_int64ToWord64"   int64ToWord64#   :: Int64# -> Word64#+foreign import ccall unsafe "hs_word64ToInt64"   word64ToInt64#   :: Word64# -> Int64#+foreign import ccall unsafe "hs_intToInt64"      intToInt64#      :: Int# -> Int64#+foreign import ccall unsafe "hs_int64ToInt"      int64ToInt#      :: Int64# -> Int#+foreign import ccall unsafe "hs_wordToWord64"    wordToWord64#    :: Word# -> Word64#+foreign import ccall unsafe "hs_word64ToWord"    word64ToWord#    :: Word64# -> Word#++#endif+
+ lib/ghc-prim/GHC/Ordering.hs view
@@ -0,0 +1,12 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Ordering where++-- We need Inl etc behind the scenes for the Ordering definition+import GHC.Generics ()++default ()++data Ordering = LT | EQ | GT+
+ lib/ghc-prim/GHC/Prim.hs view
@@ -0,0 +1,1874 @@+{-+This is a generated file (generated by genprimopcode).+It is not code to actually be used. Its only purpose is to be+consumed by haddock.+-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Prim+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC's primitive types and operations.+--+-----------------------------------------------------------------------------+module GHC.Prim (+	+-- * The word size story.+-- |Haskell98 specifies that signed integers (type @Int@)+-- 	 must contain at least 30 bits. GHC always implements @Int@ using the primitive type @Int\#@, whose size equals+-- 	 the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@.+-- 	 This is normally set based on the @config.h@ parameter+-- 	 @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64+-- 	 bits on 64-bit machines.  However, it can also be explicitly+-- 	 set to a smaller number, e.g., 31 bits, to allow the+-- 	 possibility of using tag bits. Currently GHC itself has only+-- 	 32-bit and 64-bit variants, but 30 or 31-bit code can be+-- 	 exported as an external core file for use in other back ends.+-- +-- 	 GHC also implements a primitive unsigned integer type @Word\#@ which always has the same number of bits as @Int\#@.+-- 	+-- 	 In addition, GHC supports families of explicit-sized integers+-- 	 and words at 8, 16, 32, and 64 bits, with the usual+-- 	 arithmetic operations, comparisons, and a range of+-- 	 conversions.  The 8-bit and 16-bit sizes are always+-- 	 represented as @Int\#@ and @Word\#@, and the+-- 	 operations implemented in terms of the the primops on these+-- 	 types, with suitable range restrictions on the results (using+-- 	 the @narrow$n$Int\#@ and @narrow$n$Word\#@ families+-- 	 of primops.  The 32-bit sizes are represented using @Int\#@ and @Word\#@ when @WORD\_SIZE\_IN\_BITS@+-- 	 $\geq$ 32; otherwise, these are represented using distinct+-- 	 primitive types @Int32\#@ and @Word32\#@. These (when+-- 	 needed) have a complete set of corresponding operations;+-- 	 however, nearly all of these are implemented as external C+-- 	 functions rather than as primops.  Exactly the same story+-- 	 applies to the 64-bit sizes.  All of these details are hidden+-- 	 under the @PrelInt@ and @PrelWord@ modules, which use+-- 	 @\#if@-defs to invoke the appropriate types and+-- 	 operators.+-- +-- 	 Word size also matters for the families of primops for+-- 	 indexing\/reading\/writing fixed-size quantities at offsets+-- 	 from an array base, address, or foreign pointer.  Here, a+-- 	 slightly different approach is taken.  The names of these+-- 	 primops are fixed, but their /types/ vary according to+-- 	 the value of @WORD\_SIZE\_IN\_BITS@. For example, if word+-- 	 size is at least 32 bits then an operator like+-- 	 @indexInt32Array\#@ has type @ByteArray\# -> Int\# 	 -> Int\#@; otherwise it has type @ByteArray\# -> Int\# -> 	 Int32\#@.  This approach confines the necessary @\#if@-defs to this file; no conditional compilation is needed+-- 	 in the files that expose these primops.+-- +-- 	 Finally, there are strongly deprecated primops for coercing+--          between @Addr\#@, the primitive type of machine+--          addresses, and @Int\#@.  These are pretty bogus anyway,+--          but will work on existing 32-bit and 64-bit GHC targets; they+--          are completely bogus when tag bits are used in @Int\#@,+--          so are not available in this case.  +++	+-- * Char#+-- |Operations on 31-bit characters.+++	Char#,+	gtChar#,+	geChar#,+	eqChar#,+	neChar#,+	ltChar#,+	leChar#,+	ord#,+	+-- * Int#+-- |Operations on native-size integers (30+ bits).+++	Int#,+	(+#),+	(-#),+	(*#),+	mulIntMayOflo#,+	quotInt#,+	remInt#,+	gcdInt#,+	negateInt#,+	addIntC#,+	subIntC#,+	(>#),+	(>=#),+	(==#),+	(/=#),+	(<#),+	(<=#),+	chr#,+	int2Word#,+	int2Float#,+	int2Double#,+	int2Integer#,+	uncheckedIShiftL#,+	uncheckedIShiftRA#,+	uncheckedIShiftRL#,+	+-- * Word#+-- |Operations on native-sized unsigned words (30+ bits).+++	Word#,+	plusWord#,+	minusWord#,+	timesWord#,+	quotWord#,+	remWord#,+	and#,+	or#,+	xor#,+	not#,+	uncheckedShiftL#,+	uncheckedShiftRL#,+	word2Int#,+	word2Integer#,+	gtWord#,+	geWord#,+	eqWord#,+	neWord#,+	ltWord#,+	leWord#,+	+-- * Narrowings+-- |Explicit narrowing of native-sized ints or words.+++	narrow8Int#,+	narrow16Int#,+	narrow32Int#,+	narrow8Word#,+	narrow16Word#,+	narrow32Word#,+	+-- * Integer#+-- |Operations on arbitrary-precision integers. These operations are +-- implemented via the GMP package. An integer is represented as a pair+-- consisting of an @Int\#@ representing the number of \'limbs\' in use and+-- the sign, and a @ByteArray\#@ containing the \'limbs\' themselves.  Such pairs+-- are returned as unboxed pairs, but must be passed as separate+-- components.+-- +-- For .NET these operations are implemented by foreign imports, so the+-- primops are omitted.+++	plusInteger#,+	minusInteger#,+	timesInteger#,+	gcdInteger#,+	gcdIntegerInt#,+	divExactInteger#,+	quotInteger#,+	remInteger#,+	cmpInteger#,+	cmpIntegerInt#,+	quotRemInteger#,+	divModInteger#,+	integer2Int#,+	integer2Word#,+	andInteger#,+	orInteger#,+	xorInteger#,+	complementInteger#,+	+-- * Double#+-- |Operations on double-precision (64 bit) floating-point numbers.+++	Double#,+	(>##),+	(>=##),+	(==##),+	(/=##),+	(<##),+	(<=##),+	(+##),+	(-##),+	(*##),+	(/##),+	negateDouble#,+	double2Int#,+	double2Float#,+	expDouble#,+	logDouble#,+	sqrtDouble#,+	sinDouble#,+	cosDouble#,+	tanDouble#,+	asinDouble#,+	acosDouble#,+	atanDouble#,+	sinhDouble#,+	coshDouble#,+	tanhDouble#,+	(**##),+	decodeDouble#,+	decodeDouble_2Int#,+	+-- * Float#+-- |Operations on single-precision (32-bit) floating-point numbers.+++	Float#,+	gtFloat#,+	geFloat#,+	eqFloat#,+	neFloat#,+	ltFloat#,+	leFloat#,+	plusFloat#,+	minusFloat#,+	timesFloat#,+	divideFloat#,+	negateFloat#,+	float2Int#,+	expFloat#,+	logFloat#,+	sqrtFloat#,+	sinFloat#,+	cosFloat#,+	tanFloat#,+	asinFloat#,+	acosFloat#,+	atanFloat#,+	sinhFloat#,+	coshFloat#,+	tanhFloat#,+	powerFloat#,+	float2Double#,+	decodeFloat#,+	decodeFloat_Int#,+	+-- * Arrays+-- |Operations on @Array\#@.+++	Array#,+	MutableArray#,+	newArray#,+	sameMutableArray#,+	readArray#,+	writeArray#,+	indexArray#,+	unsafeFreezeArray#,+	unsafeThawArray#,+	+-- * Byte Arrays+-- |Operations on @ByteArray\#@. A @ByteArray\#@ is a just a region of+--          raw memory in the garbage-collected heap, which is not scanned+--          for pointers. It carries its own size (in bytes). There are+-- 	 three sets of operations for accessing byte array contents:+-- 	 index for reading from immutable byte arrays, and read\/write+-- 	 for mutable byte arrays.  Each set contains operations for +-- 	 a range of useful primitive data types.  Each operation takes	+-- 	 an offset measured in terms of the size fo the primitive type+-- 	 being read or written.+++	ByteArray#,+	MutableByteArray#,+	newByteArray#,+	newPinnedByteArray#,+	newAlignedPinnedByteArray#,+	byteArrayContents#,+	sameMutableByteArray#,+	unsafeFreezeByteArray#,+	sizeofByteArray#,+	sizeofMutableByteArray#,+	indexCharArray#,+	indexWideCharArray#,+	indexIntArray#,+	indexWordArray#,+	indexAddrArray#,+	indexFloatArray#,+	indexDoubleArray#,+	indexStablePtrArray#,+	indexInt8Array#,+	indexInt16Array#,+	indexInt32Array#,+	indexInt64Array#,+	indexWord8Array#,+	indexWord16Array#,+	indexWord32Array#,+	indexWord64Array#,+	readCharArray#,+	readWideCharArray#,+	readIntArray#,+	readWordArray#,+	readAddrArray#,+	readFloatArray#,+	readDoubleArray#,+	readStablePtrArray#,+	readInt8Array#,+	readInt16Array#,+	readInt32Array#,+	readInt64Array#,+	readWord8Array#,+	readWord16Array#,+	readWord32Array#,+	readWord64Array#,+	writeCharArray#,+	writeWideCharArray#,+	writeIntArray#,+	writeWordArray#,+	writeAddrArray#,+	writeFloatArray#,+	writeDoubleArray#,+	writeStablePtrArray#,+	writeInt8Array#,+	writeInt16Array#,+	writeInt32Array#,+	writeInt64Array#,+	writeWord8Array#,+	writeWord16Array#,+	writeWord32Array#,+	writeWord64Array#,+	+-- * Addr#+-- |+++	Addr#,+	nullAddr#,+	plusAddr#,+	minusAddr#,+	remAddr#,+	addr2Int#,+	int2Addr#,+	gtAddr#,+	geAddr#,+	eqAddr#,+	neAddr#,+	ltAddr#,+	leAddr#,+	indexCharOffAddr#,+	indexWideCharOffAddr#,+	indexIntOffAddr#,+	indexWordOffAddr#,+	indexAddrOffAddr#,+	indexFloatOffAddr#,+	indexDoubleOffAddr#,+	indexStablePtrOffAddr#,+	indexInt8OffAddr#,+	indexInt16OffAddr#,+	indexInt32OffAddr#,+	indexInt64OffAddr#,+	indexWord8OffAddr#,+	indexWord16OffAddr#,+	indexWord32OffAddr#,+	indexWord64OffAddr#,+	readCharOffAddr#,+	readWideCharOffAddr#,+	readIntOffAddr#,+	readWordOffAddr#,+	readAddrOffAddr#,+	readFloatOffAddr#,+	readDoubleOffAddr#,+	readStablePtrOffAddr#,+	readInt8OffAddr#,+	readInt16OffAddr#,+	readInt32OffAddr#,+	readInt64OffAddr#,+	readWord8OffAddr#,+	readWord16OffAddr#,+	readWord32OffAddr#,+	readWord64OffAddr#,+	writeCharOffAddr#,+	writeWideCharOffAddr#,+	writeIntOffAddr#,+	writeWordOffAddr#,+	writeAddrOffAddr#,+	writeFloatOffAddr#,+	writeDoubleOffAddr#,+	writeStablePtrOffAddr#,+	writeInt8OffAddr#,+	writeInt16OffAddr#,+	writeInt32OffAddr#,+	writeInt64OffAddr#,+	writeWord8OffAddr#,+	writeWord16OffAddr#,+	writeWord32OffAddr#,+	writeWord64OffAddr#,+	+-- * Mutable variables+-- |Operations on MutVar\#s.+++	MutVar#,+	newMutVar#,+	readMutVar#,+	writeMutVar#,+	sameMutVar#,+	atomicModifyMutVar#,+	+-- * Exceptions+-- |+++	catch#,+	raise#,+	raiseIO#,+	blockAsyncExceptions#,+	unblockAsyncExceptions#,+	asyncExceptionsBlocked#,+	+-- * STM-accessible Mutable Variables+-- |+++	TVar#,+	atomically#,+	retry#,+	catchRetry#,+	catchSTM#,+	check#,+	newTVar#,+	readTVar#,+	writeTVar#,+	sameTVar#,+	+-- * Synchronized Mutable Variables+-- |Operations on @MVar\#@s. +++	MVar#,+	newMVar#,+	takeMVar#,+	tryTakeMVar#,+	putMVar#,+	tryPutMVar#,+	sameMVar#,+	isEmptyMVar#,+	+-- * Delay\/wait operations+-- |+++	delay#,+	waitRead#,+	waitWrite#,+	+-- * Concurrency primitives+-- |+++	State#,+	RealWorld,+	ThreadId#,+	fork#,+	forkOn#,+	killThread#,+	yield#,+	myThreadId#,+	labelThread#,+	isCurrentThreadBound#,+	noDuplicate#,+	threadStatus#,+	+-- * Weak pointers+-- |+++	Weak#,+	mkWeak#,+	mkWeakForeignEnv#,+	deRefWeak#,+	finalizeWeak#,+	touch#,+	+-- * Stable pointers and names+-- |+++	StablePtr#,+	StableName#,+	makeStablePtr#,+	deRefStablePtr#,+	eqStablePtr#,+	makeStableName#,+	eqStableName#,+	stableNameToInt#,+	+-- * Unsafe pointer equality+-- |+++	reallyUnsafePtrEquality#,+	+-- * Parallelism+-- |+++	par#,+	parGlobal#,+	parLocal#,+	parAt#,+	parAtAbs#,+	parAtRel#,+	parAtForNow#,+	+-- * Tag to enum stuff+-- |Convert back and forth between values of enumerated types+-- 	and small integers.+++	dataToTag#,+	tagToEnum#,+	+-- * Bytecode operations+-- |Support for the bytecode interpreter and linker.+++	BCO#,+	addrToHValue#,+	mkApUpd0#,+	newBCO#,+	unpackClosure#,+	getApStackVal#,+	+-- * Etc+-- |Miscellaneous built-ins+++	seq,+	inline,+	lazy,+	Any,+	unsafeCoerce#,+) where++import GHC.Bool++{-+has_side_effects = False+out_of_line = False+commutable = False+needs_wrapper = False+can_fail = False+strictness = {  \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }+-}++data Char#++gtChar# :: Char# -> Char# -> Bool+gtChar# = let x = x in x++geChar# :: Char# -> Char# -> Bool+geChar# = let x = x in x++eqChar# :: Char# -> Char# -> Bool+eqChar# = let x = x in x++neChar# :: Char# -> Char# -> Bool+neChar# = let x = x in x++ltChar# :: Char# -> Char# -> Bool+ltChar# = let x = x in x++leChar# :: Char# -> Char# -> Bool+leChar# = let x = x in x++ord# :: Char# -> Int#+ord# = let x = x in x++data Int#++(+#) :: Int# -> Int# -> Int#+(+#) = let x = x in x++(-#) :: Int# -> Int# -> Int#+(-#) = let x = x in x++-- |Low word of signed integer multiply.++(*#) :: Int# -> Int# -> Int#+(*#) = let x = x in x++-- |Return non-zero if there is any possibility that the upper word of a+--     signed integer multiply might contain useful information.  Return+--     zero only if you are completely sure that no overflow can occur.+--     On a 32-bit platform, the recommmended implementation is to do a +--     32 x 32 -> 64 signed multiply, and subtract result[63:32] from+--     (result[31] >>signed 31).  If this is zero, meaning that the +--     upper word is merely a sign extension of the lower one, no+--     overflow can occur.+-- +--     On a 64-bit platform it is not always possible to +--     acquire the top 64 bits of the result.  Therefore, a recommended +--     implementation is to take the absolute value of both operands, and +--     return 0 iff bits[63:31] of them are zero, since that means that their +--     magnitudes fit within 31 bits, so the magnitude of the product must fit +--     into 62 bits.+-- +--     If in doubt, return non-zero, but do make an effort to create the+--     correct answer for small args, since otherwise the performance of+--     @(*) :: Integer -> Integer -> Integer@ will be poor.+--    ++mulIntMayOflo# :: Int# -> Int# -> Int#+mulIntMayOflo# = let x = x in x++-- |Rounds towards zero.++quotInt# :: Int# -> Int# -> Int#+quotInt# = let x = x in x++-- |Satisfies @(quotInt\# x y) *\# y +\# (remInt\# x y) == x@.++remInt# :: Int# -> Int# -> Int#+remInt# = let x = x in x++gcdInt# :: Int# -> Int# -> Int#+gcdInt# = let x = x in x++negateInt# :: Int# -> Int#+negateInt# = let x = x in x++-- |Add with carry.  First member of result is (wrapped) sum; +--           second member is 0 iff no overflow occured.++addIntC# :: Int# -> Int# -> (# Int#,Int# #)+addIntC# = let x = x in x++-- |Subtract with carry.  First member of result is (wrapped) difference; +--           second member is 0 iff no overflow occured.++subIntC# :: Int# -> Int# -> (# Int#,Int# #)+subIntC# = let x = x in x++(>#) :: Int# -> Int# -> Bool+(>#) = let x = x in x++(>=#) :: Int# -> Int# -> Bool+(>=#) = let x = x in x++(==#) :: Int# -> Int# -> Bool+(==#) = let x = x in x++(/=#) :: Int# -> Int# -> Bool+(/=#) = let x = x in x++(<#) :: Int# -> Int# -> Bool+(<#) = let x = x in x++(<=#) :: Int# -> Int# -> Bool+(<=#) = let x = x in x++chr# :: Int# -> Char#+chr# = let x = x in x++int2Word# :: Int# -> Word#+int2Word# = let x = x in x++int2Float# :: Int# -> Float#+int2Float# = let x = x in x++int2Double# :: Int# -> Double#+int2Double# = let x = x in x++int2Integer# :: Int# -> (# Int#,ByteArray# #)+int2Integer# = let x = x in x++-- |Shift left.  Result undefined if shift amount is not+--           in the range 0 to word size - 1 inclusive.++uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftL# = let x = x in x++-- |Shift right arithmetic.  Result undefined if shift amount is not+--           in the range 0 to word size - 1 inclusive.++uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRA# = let x = x in x++-- |Shift right logical.  Result undefined if shift amount is not+--           in the range 0 to word size - 1 inclusive.++uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedIShiftRL# = let x = x in x++data Word#++plusWord# :: Word# -> Word# -> Word#+plusWord# = let x = x in x++minusWord# :: Word# -> Word# -> Word#+minusWord# = let x = x in x++timesWord# :: Word# -> Word# -> Word#+timesWord# = let x = x in x++quotWord# :: Word# -> Word# -> Word#+quotWord# = let x = x in x++remWord# :: Word# -> Word# -> Word#+remWord# = let x = x in x++and# :: Word# -> Word# -> Word#+and# = let x = x in x++or# :: Word# -> Word# -> Word#+or# = let x = x in x++xor# :: Word# -> Word# -> Word#+xor# = let x = x in x++not# :: Word# -> Word#+not# = let x = x in x++-- |Shift left logical.   Result undefined if shift amount is not+--           in the range 0 to word size - 1 inclusive.++uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftL# = let x = x in x++-- |Shift right logical.   Result undefined if shift  amount is not+--           in the range 0 to word size - 1 inclusive.++uncheckedShiftRL# :: Word# -> Int# -> Word#+uncheckedShiftRL# = let x = x in x++word2Int# :: Word# -> Int#+word2Int# = let x = x in x++word2Integer# :: Word# -> (# Int#,ByteArray# #)+word2Integer# = let x = x in x++gtWord# :: Word# -> Word# -> Bool+gtWord# = let x = x in x++geWord# :: Word# -> Word# -> Bool+geWord# = let x = x in x++eqWord# :: Word# -> Word# -> Bool+eqWord# = let x = x in x++neWord# :: Word# -> Word# -> Bool+neWord# = let x = x in x++ltWord# :: Word# -> Word# -> Bool+ltWord# = let x = x in x++leWord# :: Word# -> Word# -> Bool+leWord# = let x = x in x++narrow8Int# :: Int# -> Int#+narrow8Int# = let x = x in x++narrow16Int# :: Int# -> Int#+narrow16Int# = let x = x in x++narrow32Int# :: Int# -> Int#+narrow32Int# = let x = x in x++narrow8Word# :: Word# -> Word#+narrow8Word# = let x = x in x++narrow16Word# :: Word# -> Word#+narrow16Word# = let x = x in x++narrow32Word# :: Word# -> Word#+narrow32Word# = let x = x in x++plusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+plusInteger# = let x = x in x++minusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+minusInteger# = let x = x in x++timesInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+timesInteger# = let x = x in x++-- |Greatest common divisor.++gcdInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+gcdInteger# = let x = x in x++-- |Greatest common divisor, where second argument is an ordinary @Int\#@.++gcdIntegerInt# :: Int# -> ByteArray# -> Int# -> Int#+gcdIntegerInt# = let x = x in x++-- |Divisor is guaranteed to be a factor of dividend.++divExactInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+divExactInteger# = let x = x in x++-- |Rounds towards zero.++quotInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+quotInteger# = let x = x in x++-- |Satisfies @plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x@.++remInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+remInteger# = let x = x in x++-- |Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument.++cmpInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int#+cmpInteger# = let x = x in x++-- |Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which+--    is an ordinary Int\#.++cmpIntegerInt# :: Int# -> ByteArray# -> Int# -> Int#+cmpIntegerInt# = let x = x in x++-- |Compute quot and rem simulaneously.++quotRemInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #)+quotRemInteger# = let x = x in x++-- |Compute div and mod simultaneously, where div rounds towards negative infinity+--     and@(q,r) = divModInteger\#(x,y)@ implies @plusInteger\# (timesInteger\# q y) r = x@.++divModInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #)+divModInteger# = let x = x in x++integer2Int# :: Int# -> ByteArray# -> Int#+integer2Int# = let x = x in x++integer2Word# :: Int# -> ByteArray# -> Word#+integer2Word# = let x = x in x++andInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+andInteger# = let x = x in x++orInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+orInteger# = let x = x in x++xorInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+xorInteger# = let x = x in x++complementInteger# :: Int# -> ByteArray# -> (# Int#,ByteArray# #)+complementInteger# = let x = x in x++data Double#++(>##) :: Double# -> Double# -> Bool+(>##) = let x = x in x++(>=##) :: Double# -> Double# -> Bool+(>=##) = let x = x in x++(==##) :: Double# -> Double# -> Bool+(==##) = let x = x in x++(/=##) :: Double# -> Double# -> Bool+(/=##) = let x = x in x++(<##) :: Double# -> Double# -> Bool+(<##) = let x = x in x++(<=##) :: Double# -> Double# -> Bool+(<=##) = let x = x in x++(+##) :: Double# -> Double# -> Double#+(+##) = let x = x in x++(-##) :: Double# -> Double# -> Double#+(-##) = let x = x in x++(*##) :: Double# -> Double# -> Double#+(*##) = let x = x in x++(/##) :: Double# -> Double# -> Double#+(/##) = let x = x in x++negateDouble# :: Double# -> Double#+negateDouble# = let x = x in x++-- |Truncates a @Double#@ value to the nearest @Int#@.+--     Results are undefined if the truncation if truncation yields+--     a value outside the range of @Int#@.++double2Int# :: Double# -> Int#+double2Int# = let x = x in x++double2Float# :: Double# -> Float#+double2Float# = let x = x in x++expDouble# :: Double# -> Double#+expDouble# = let x = x in x++logDouble# :: Double# -> Double#+logDouble# = let x = x in x++sqrtDouble# :: Double# -> Double#+sqrtDouble# = let x = x in x++sinDouble# :: Double# -> Double#+sinDouble# = let x = x in x++cosDouble# :: Double# -> Double#+cosDouble# = let x = x in x++tanDouble# :: Double# -> Double#+tanDouble# = let x = x in x++asinDouble# :: Double# -> Double#+asinDouble# = let x = x in x++acosDouble# :: Double# -> Double#+acosDouble# = let x = x in x++atanDouble# :: Double# -> Double#+atanDouble# = let x = x in x++sinhDouble# :: Double# -> Double#+sinhDouble# = let x = x in x++coshDouble# :: Double# -> Double#+coshDouble# = let x = x in x++tanhDouble# :: Double# -> Double#+tanhDouble# = let x = x in x++-- |Exponentiation.++(**##) :: Double# -> Double# -> Double#+(**##) = let x = x in x++-- |Convert to arbitrary-precision integer.+--     First @Int\#@ in result is the exponent; second @Int\#@ and @ByteArray\#@+--     represent an @Integer\#@ holding the mantissa.++decodeDouble# :: Double# -> (# Int#,Int#,ByteArray# #)+decodeDouble# = let x = x in x++-- |Convert to arbitrary-precision integer.+--     First component of the result is -1 or 1, indicating the sign of the+--     mantissa. The next two are the high and low 32 bits of the mantissa+--     respectively, and the last is the exponent.++decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #)+decodeDouble_2Int# = let x = x in x++data Float#++gtFloat# :: Float# -> Float# -> Bool+gtFloat# = let x = x in x++geFloat# :: Float# -> Float# -> Bool+geFloat# = let x = x in x++eqFloat# :: Float# -> Float# -> Bool+eqFloat# = let x = x in x++neFloat# :: Float# -> Float# -> Bool+neFloat# = let x = x in x++ltFloat# :: Float# -> Float# -> Bool+ltFloat# = let x = x in x++leFloat# :: Float# -> Float# -> Bool+leFloat# = let x = x in x++plusFloat# :: Float# -> Float# -> Float#+plusFloat# = let x = x in x++minusFloat# :: Float# -> Float# -> Float#+minusFloat# = let x = x in x++timesFloat# :: Float# -> Float# -> Float#+timesFloat# = let x = x in x++divideFloat# :: Float# -> Float# -> Float#+divideFloat# = let x = x in x++negateFloat# :: Float# -> Float#+negateFloat# = let x = x in x++-- |Truncates a @Float#@ value to the nearest @Int#@.+--     Results are undefined if the truncation if truncation yields+--     a value outside the range of @Int#@.++float2Int# :: Float# -> Int#+float2Int# = let x = x in x++expFloat# :: Float# -> Float#+expFloat# = let x = x in x++logFloat# :: Float# -> Float#+logFloat# = let x = x in x++sqrtFloat# :: Float# -> Float#+sqrtFloat# = let x = x in x++sinFloat# :: Float# -> Float#+sinFloat# = let x = x in x++cosFloat# :: Float# -> Float#+cosFloat# = let x = x in x++tanFloat# :: Float# -> Float#+tanFloat# = let x = x in x++asinFloat# :: Float# -> Float#+asinFloat# = let x = x in x++acosFloat# :: Float# -> Float#+acosFloat# = let x = x in x++atanFloat# :: Float# -> Float#+atanFloat# = let x = x in x++sinhFloat# :: Float# -> Float#+sinhFloat# = let x = x in x++coshFloat# :: Float# -> Float#+coshFloat# = let x = x in x++tanhFloat# :: Float# -> Float#+tanhFloat# = let x = x in x++powerFloat# :: Float# -> Float# -> Float#+powerFloat# = let x = x in x++float2Double# :: Float# -> Double#+float2Double# = let x = x in x++-- |Convert to arbitrary-precision integer.+--     First @Int\#@ in result is the exponent; second @Int\#@ and @ByteArray\#@+--     represent an @Integer\#@ holding the mantissa.++decodeFloat# :: Float# -> (# Int#,Int#,ByteArray# #)+decodeFloat# = let x = x in x++-- |Convert to arbitrary-precision integer.+--     First @Int\#@ in result is the mantissa; second is the exponent.++decodeFloat_Int# :: Float# -> (# Int#,Int# #)+decodeFloat_Int# = let x = x in x++data Array# a++data MutableArray# s a++-- |Create a new mutable array of specified size (in bytes),+--     in the specified state thread,+--     with each element containing the specified initial value.++newArray# :: Int# -> a -> State# s -> (# State# s,MutableArray# s a #)+newArray# = let x = x in x++sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool+sameMutableArray# = let x = x in x++-- |Read from specified index of mutable array. Result is not yet evaluated.++readArray# :: MutableArray# s a -> Int# -> State# s -> (# State# s,a #)+readArray# = let x = x in x++-- |Write to specified index of mutable array.++writeArray# :: MutableArray# s a -> Int# -> a -> State# s -> State# s+writeArray# = let x = x in x++-- |Read from specified index of immutable array. Result is packaged into+--     an unboxed singleton; the result itself is not yet evaluated.++indexArray# :: Array# a -> Int# -> (# a #)+indexArray# = let x = x in x++-- |Make a mutable array immutable, without copying.++unsafeFreezeArray# :: MutableArray# s a -> State# s -> (# State# s,Array# a #)+unsafeFreezeArray# = let x = x in x++-- |Make an immutable array mutable, without copying.++unsafeThawArray# :: Array# a -> State# s -> (# State# s,MutableArray# s a #)+unsafeThawArray# = let x = x in x++data ByteArray#++data MutableByteArray# s++-- |Create a new mutable byte array of specified size (in bytes), in+--     the specified state thread.++newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newByteArray# = let x = x in x++-- |Create a mutable byte array that the GC guarantees not to move.++newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newPinnedByteArray# = let x = x in x++-- |Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move.++newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+newAlignedPinnedByteArray# = let x = x in x++-- |Intended for use with pinned arrays; otherwise very unsafe!++byteArrayContents# :: ByteArray# -> Addr#+byteArrayContents# = let x = x in x++sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool+sameMutableByteArray# = let x = x in x++-- |Make a mutable byte array immutable, without copying.++unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #)+unsafeFreezeByteArray# = let x = x in x++sizeofByteArray# :: ByteArray# -> Int#+sizeofByteArray# = let x = x in x++sizeofMutableByteArray# :: MutableByteArray# s -> Int#+sizeofMutableByteArray# = let x = x in x++-- |Read 8-bit character; offset in bytes.++indexCharArray# :: ByteArray# -> Int# -> Char#+indexCharArray# = let x = x in x++-- |Read 31-bit character; offset in 4-byte words.++indexWideCharArray# :: ByteArray# -> Int# -> Char#+indexWideCharArray# = let x = x in x++indexIntArray# :: ByteArray# -> Int# -> Int#+indexIntArray# = let x = x in x++indexWordArray# :: ByteArray# -> Int# -> Word#+indexWordArray# = let x = x in x++indexAddrArray# :: ByteArray# -> Int# -> Addr#+indexAddrArray# = let x = x in x++indexFloatArray# :: ByteArray# -> Int# -> Float#+indexFloatArray# = let x = x in x++indexDoubleArray# :: ByteArray# -> Int# -> Double#+indexDoubleArray# = let x = x in x++indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a+indexStablePtrArray# = let x = x in x++indexInt8Array# :: ByteArray# -> Int# -> Int#+indexInt8Array# = let x = x in x++indexInt16Array# :: ByteArray# -> Int# -> Int#+indexInt16Array# = let x = x in x++indexInt32Array# :: ByteArray# -> Int# -> Int#+indexInt32Array# = let x = x in x++indexInt64Array# :: ByteArray# -> Int# -> Int#+indexInt64Array# = let x = x in x++indexWord8Array# :: ByteArray# -> Int# -> Word#+indexWord8Array# = let x = x in x++indexWord16Array# :: ByteArray# -> Int# -> Word#+indexWord16Array# = let x = x in x++indexWord32Array# :: ByteArray# -> Int# -> Word#+indexWord32Array# = let x = x in x++indexWord64Array# :: ByteArray# -> Int# -> Word#+indexWord64Array# = let x = x in x++-- |Read 8-bit character; offset in bytes.++readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readCharArray# = let x = x in x++-- |Read 31-bit character; offset in 4-byte words.++readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWideCharArray# = let x = x in x++readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readIntArray# = let x = x in x++readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWordArray# = let x = x in x++readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readAddrArray# = let x = x in x++readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readFloatArray# = let x = x in x++readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readDoubleArray# = let x = x in x++readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrArray# = let x = x in x++readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt8Array# = let x = x in x++readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt16Array# = let x = x in x++readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt32Array# = let x = x in x++readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt64Array# = let x = x in x++readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord8Array# = let x = x in x++readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord16Array# = let x = x in x++readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord32Array# = let x = x in x++readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord64Array# = let x = x in x++-- |Write 8-bit character; offset in bytes.++writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeCharArray# = let x = x in x++-- |Write 31-bit character; offset in 4-byte words.++writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# = let x = x in x++writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeIntArray# = let x = x in x++writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWordArray# = let x = x in x++writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeAddrArray# = let x = x in x++writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeFloatArray# = let x = x in x++writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeDoubleArray# = let x = x in x++writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrArray# = let x = x in x++writeInt8Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt8Array# = let x = x in x++writeInt16Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt16Array# = let x = x in x++writeInt32Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt32Array# = let x = x in x++writeInt64Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt64Array# = let x = x in x++writeWord8Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord8Array# = let x = x in x++writeWord16Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord16Array# = let x = x in x++writeWord32Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord32Array# = let x = x in x++writeWord64Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord64Array# = let x = x in x++-- | An arbitrary machine address assumed to point outside+-- 	 the garbage-collected heap. ++data Addr#++-- | The null address. ++nullAddr# :: Addr#+nullAddr# = let x = x in x++plusAddr# :: Addr# -> Int# -> Addr#+plusAddr# = let x = x in x++-- |Result is meaningless if two @Addr\#@s are so far apart that their+-- 	 difference doesn\'t fit in an @Int\#@.++minusAddr# :: Addr# -> Addr# -> Int#+minusAddr# = let x = x in x++-- |Return the remainder when the @Addr\#@ arg, treated like an @Int\#@,+-- 	  is divided by the @Int\#@ arg.++remAddr# :: Addr# -> Int# -> Int#+remAddr# = let x = x in x++-- |Coerce directly from address to int. Strongly deprecated.++addr2Int# :: Addr# -> Int#+addr2Int# = let x = x in x++-- |Coerce directly from int to address. Strongly deprecated.++int2Addr# :: Int# -> Addr#+int2Addr# = let x = x in x++gtAddr# :: Addr# -> Addr# -> Bool+gtAddr# = let x = x in x++geAddr# :: Addr# -> Addr# -> Bool+geAddr# = let x = x in x++eqAddr# :: Addr# -> Addr# -> Bool+eqAddr# = let x = x in x++neAddr# :: Addr# -> Addr# -> Bool+neAddr# = let x = x in x++ltAddr# :: Addr# -> Addr# -> Bool+ltAddr# = let x = x in x++leAddr# :: Addr# -> Addr# -> Bool+leAddr# = let x = x in x++-- |Reads 8-bit character; offset in bytes.++indexCharOffAddr# :: Addr# -> Int# -> Char#+indexCharOffAddr# = let x = x in x++-- |Reads 31-bit character; offset in 4-byte words.++indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# = let x = x in x++indexIntOffAddr# :: Addr# -> Int# -> Int#+indexIntOffAddr# = let x = x in x++indexWordOffAddr# :: Addr# -> Int# -> Word#+indexWordOffAddr# = let x = x in x++indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexAddrOffAddr# = let x = x in x++indexFloatOffAddr# :: Addr# -> Int# -> Float#+indexFloatOffAddr# = let x = x in x++indexDoubleOffAddr# :: Addr# -> Int# -> Double#+indexDoubleOffAddr# = let x = x in x++indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a+indexStablePtrOffAddr# = let x = x in x++indexInt8OffAddr# :: Addr# -> Int# -> Int#+indexInt8OffAddr# = let x = x in x++indexInt16OffAddr# :: Addr# -> Int# -> Int#+indexInt16OffAddr# = let x = x in x++indexInt32OffAddr# :: Addr# -> Int# -> Int#+indexInt32OffAddr# = let x = x in x++indexInt64OffAddr# :: Addr# -> Int# -> Int#+indexInt64OffAddr# = let x = x in x++indexWord8OffAddr# :: Addr# -> Int# -> Word#+indexWord8OffAddr# = let x = x in x++indexWord16OffAddr# :: Addr# -> Int# -> Word#+indexWord16OffAddr# = let x = x in x++indexWord32OffAddr# :: Addr# -> Int# -> Word#+indexWord32OffAddr# = let x = x in x++indexWord64OffAddr# :: Addr# -> Int# -> Word#+indexWord64OffAddr# = let x = x in x++-- |Reads 8-bit character; offset in bytes.++readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readCharOffAddr# = let x = x in x++-- |Reads 31-bit character; offset in 4-byte words.++readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWideCharOffAddr# = let x = x in x++readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readIntOffAddr# = let x = x in x++readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWordOffAddr# = let x = x in x++readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readAddrOffAddr# = let x = x in x++readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readFloatOffAddr# = let x = x in x++readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readDoubleOffAddr# = let x = x in x++readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrOffAddr# = let x = x in x++readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt8OffAddr# = let x = x in x++readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt16OffAddr# = let x = x in x++readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt32OffAddr# = let x = x in x++readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt64OffAddr# = let x = x in x++readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord8OffAddr# = let x = x in x++readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord16OffAddr# = let x = x in x++readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord32OffAddr# = let x = x in x++readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord64OffAddr# = let x = x in x++writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeCharOffAddr# = let x = x in x++writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# = let x = x in x++writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeIntOffAddr# = let x = x in x++writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWordOffAddr# = let x = x in x++writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeAddrOffAddr# = let x = x in x++writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeFloatOffAddr# = let x = x in x++writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeDoubleOffAddr# = let x = x in x++writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrOffAddr# = let x = x in x++writeInt8OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt8OffAddr# = let x = x in x++writeInt16OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt16OffAddr# = let x = x in x++writeInt32OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt32OffAddr# = let x = x in x++writeInt64OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt64OffAddr# = let x = x in x++writeWord8OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord8OffAddr# = let x = x in x++writeWord16OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord16OffAddr# = let x = x in x++writeWord32OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord32OffAddr# = let x = x in x++writeWord64OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord64OffAddr# = let x = x in x++-- |A @MutVar\#@ behaves like a single-element mutable array.++data MutVar# s a++-- |Create @MutVar\#@ with specified initial value in specified state thread.++newMutVar# :: a -> State# s -> (# State# s,MutVar# s a #)+newMutVar# = let x = x in x++-- |Read contents of @MutVar\#@. Result is not yet evaluated.++readMutVar# :: MutVar# s a -> State# s -> (# State# s,a #)+readMutVar# = let x = x in x++-- |Write contents of @MutVar\#@.++writeMutVar# :: MutVar# s a -> a -> State# s -> State# s+writeMutVar# = let x = x in x++sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool+sameMutVar# = let x = x in x++atomicModifyMutVar# :: MutVar# s a -> (a -> b) -> State# s -> (# State# s,c #)+atomicModifyMutVar# = let x = x in x++catch# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+catch# = let x = x in x++raise# :: a -> b+raise# = let x = x in x++raiseIO# :: a -> State# (RealWorld) -> (# State# (RealWorld),b #)+raiseIO# = let x = x in x++blockAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+blockAsyncExceptions# = let x = x in x++unblockAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+unblockAsyncExceptions# = let x = x in x++asyncExceptionsBlocked# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+asyncExceptionsBlocked# = let x = x in x++data TVar# s a++atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+atomically# = let x = x in x++retry# :: State# (RealWorld) -> (# State# (RealWorld),a #)+retry# = let x = x in x++catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+catchRetry# = let x = x in x++catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+catchSTM# = let x = x in x++check# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),() #)+check# = let x = x in x++-- |Create a new @TVar\#@ holding a specified initial value.++newTVar# :: a -> State# s -> (# State# s,TVar# s a #)+newTVar# = let x = x in x++-- |Read contents of @TVar\#@.  Result is not yet evaluated.++readTVar# :: TVar# s a -> State# s -> (# State# s,a #)+readTVar# = let x = x in x++-- |Write contents of @TVar\#@.++writeTVar# :: TVar# s a -> a -> State# s -> State# s+writeTVar# = let x = x in x++sameTVar# :: TVar# s a -> TVar# s a -> Bool+sameTVar# = let x = x in x++-- | A shared mutable variable (/not/ the same as a @MutVar\#@!).+-- 	(Note: in a non-concurrent implementation, @(MVar\# a)@ can be+-- 	represented by @(MutVar\# (Maybe a))@.) ++data MVar# s a++-- |Create new @MVar\#@; initially empty.++newMVar# :: State# s -> (# State# s,MVar# s a #)+newMVar# = let x = x in x++-- |If @MVar\#@ is empty, block until it becomes full.+--    Then remove and return its contents, and set it empty.++takeMVar# :: MVar# s a -> State# s -> (# State# s,a #)+takeMVar# = let x = x in x++-- |If @MVar\#@ is empty, immediately return with integer 0 and value undefined.+--    Otherwise, return with integer 1 and contents of @MVar\#@, and set @MVar\#@ empty.++tryTakeMVar# :: MVar# s a -> State# s -> (# State# s,Int#,a #)+tryTakeMVar# = let x = x in x++-- |If @MVar\#@ is full, block until it becomes empty.+--    Then store value arg as its new contents.++putMVar# :: MVar# s a -> a -> State# s -> State# s+putMVar# = let x = x in x++-- |If @MVar\#@ is full, immediately return with integer 0.+--     Otherwise, store value arg as @MVar\#@\'s new contents, and return with integer 1.++tryPutMVar# :: MVar# s a -> a -> State# s -> (# State# s,Int# #)+tryPutMVar# = let x = x in x++sameMVar# :: MVar# s a -> MVar# s a -> Bool+sameMVar# = let x = x in x++-- |Return 1 if @MVar\#@ is empty; 0 otherwise.++isEmptyMVar# :: MVar# s a -> State# s -> (# State# s,Int# #)+isEmptyMVar# = let x = x in x++-- |Sleep specified number of microseconds.++delay# :: Int# -> State# s -> State# s+delay# = let x = x in x++-- |Block until input is available on specified file descriptor.++waitRead# :: Int# -> State# s -> State# s+waitRead# = let x = x in x++-- |Block until output is possible on specified file descriptor.++waitWrite# :: Int# -> State# s -> State# s+waitWrite# = let x = x in x++-- | @State\#@ is the primitive, unlifted type of states.  It has+-- 	one type parameter, thus @State\# RealWorld@, or @State\# s@,+-- 	where s is a type variable. The only purpose of the type parameter+-- 	is to keep different state threads separate.  It is represented by+-- 	nothing at all. ++data State# s++-- | @RealWorld@ is deeply magical.  It is /primitive/, but it is not+-- 	/unlifted/ (hence @ptrArg@).  We never manipulate values of type+-- 	@RealWorld@; it\'s only used in the type system, to parameterise @State\#@. ++data RealWorld++-- |(In a non-concurrent implementation, this can be a singleton+-- 	type, whose (unique) value is returned by @myThreadId\#@.  The +-- 	other operations can be omitted.)++data ThreadId#++fork# :: a -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+fork# = let x = x in x++forkOn# :: Int# -> a -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+forkOn# = let x = x in x++killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld)+killThread# = let x = x in x++yield# :: State# (RealWorld) -> State# (RealWorld)+yield# = let x = x in x++myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+myThreadId# = let x = x in x++labelThread# :: ThreadId# -> Addr# -> State# (RealWorld) -> State# (RealWorld)+labelThread# = let x = x in x++isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+isCurrentThreadBound# = let x = x in x++noDuplicate# :: State# (RealWorld) -> State# (RealWorld)+noDuplicate# = let x = x in x++threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+threadStatus# = let x = x in x++data Weak# b++mkWeak# :: o -> b -> c -> State# (RealWorld) -> (# State# (RealWorld),Weak# b #)+mkWeak# = let x = x in x++mkWeakForeignEnv# :: o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Weak# b #)+mkWeakForeignEnv# = let x = x in x++deRefWeak# :: Weak# a -> State# (RealWorld) -> (# State# (RealWorld),Int#,a #)+deRefWeak# = let x = x in x++finalizeWeak# :: Weak# a -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),() #) #)+finalizeWeak# = let x = x in x++touch# :: o -> State# (RealWorld) -> State# (RealWorld)+touch# = let x = x in x++data StablePtr# a++data StableName# a++makeStablePtr# :: a -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a #)+makeStablePtr# = let x = x in x++deRefStablePtr# :: StablePtr# a -> State# (RealWorld) -> (# State# (RealWorld),a #)+deRefStablePtr# = let x = x in x++eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#+eqStablePtr# = let x = x in x++makeStableName# :: a -> State# (RealWorld) -> (# State# (RealWorld),StableName# a #)+makeStableName# = let x = x in x++eqStableName# :: StableName# a -> StableName# a -> Int#+eqStableName# = let x = x in x++stableNameToInt# :: StableName# a -> Int#+stableNameToInt# = let x = x in x++reallyUnsafePtrEquality# :: a -> a -> Int#+reallyUnsafePtrEquality# = let x = x in x++par# :: a -> Int#+par# = let x = x in x++parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#+parGlobal# = let x = x in x++parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#+parLocal# = let x = x in x++parAt# :: b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int#+parAt# = let x = x in x++parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#+parAtAbs# = let x = x in x++parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#+parAtRel# = let x = x in x++parAtForNow# :: b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int#+parAtForNow# = let x = x in x++dataToTag# :: a -> Int#+dataToTag# = let x = x in x++tagToEnum# :: Int# -> a+tagToEnum# = let x = x in x++-- |Primitive bytecode type.++data BCO#++-- |Convert an @Addr\#@ to a followable type.++addrToHValue# :: Addr# -> (# a #)+addrToHValue# = let x = x in x++mkApUpd0# :: BCO# -> (# a #)+mkApUpd0# = let x = x in x++newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO# #)+newBCO# = let x = x in x++unpackClosure# :: a -> (# Addr#,Array# b,ByteArray# #)+unpackClosure# = let x = x in x++getApStackVal# :: a -> Int# -> (# Int#,b #)+getApStackVal# = let x = x in x++-- | Evaluates its first argument to head normal form, and then returns its second+-- 	argument as the result. ++seq :: a -> b -> b+seq = let x = x in x++-- | The call @(inline f)@ arranges that f is inlined, regardless of its size.+-- 	More precisely, the call @(inline f)@ rewrites to the right-hand side of+-- 	@f@\'s definition. This allows the programmer to control inlining from a+-- 	particular call site rather than the definition site of the function (c.f.+-- 	@INLINE@ pragmas in User\'s Guide, Section 7.10.3, \"INLINE and NOINLINE+-- 	pragmas\").+-- +-- 	This inlining occurs regardless of the argument to the call or the size of+-- 	@f@\'s definition; it is unconditional. The main caveat is that @f@\'s+-- 	definition must be visible to the compiler. That is, @f@ must be+-- 	@let@-bound in the current scope. If no inlining takes place, the+-- 	@inline@ function expands to the identity function in Phase zero; so its+-- 	use imposes no overhead.+-- +-- 	If the function is defined in another module, GHC only exposes its inlining+-- 	in the interface file if the function is sufficiently small that it might be+-- 	inlined by the automatic mechanism. There is currently no way to tell GHC to+-- 	expose arbitrarily-large functions in the interface file. (This shortcoming+-- 	is something that could be fixed, with some kind of pragma.) ++inline :: a -> a+inline = let x = x in x++-- | The @lazy@ function restrains strictness analysis a little. The call+-- 	@(lazy e)@ means the same as @e@, but @lazy@ has a magical+-- 	property so far as strictness analysis is concerned: it is lazy in its first+-- 	argument, even though its semantics is strict. After strictness analysis has+-- 	run, calls to @lazy@ are inlined to be the identity function.+-- +-- 	This behaviour is occasionally useful when controlling evaluation order.+-- 	Notably, @lazy@ is used in the library definition of @Control.Parallel.par@:+-- +-- 	@par :: a -> b -> b@+-- +-- 	@par x y = case (par\# x) of \_ -> lazy y@+-- +-- 	If @lazy@ were not lazy, @par@ would look strict in @y@ which+-- 	would defeat the whole purpose of @par@.+-- +-- 	Like @seq@, the argument of @lazy@ can have an unboxed type. ++lazy :: a -> a+lazy = let x = x in x++-- | The type constructor @Any@ is type to which you can unsafely coerce any+-- 	lifted type, and back. +-- +-- 	  * It is lifted, and hence represented by a pointer+-- +-- 	  * It does not claim to be a /data/ type, and that\'s important for+-- 	    the code generator, because the code gen may /enter/ a data value+-- 	    but never enters a function value.  +-- +-- 	It\'s also used to instantiate un-constrained type variables after type+-- 	checking.  For example+-- +-- 	@length Any []@+-- +-- 	Annoyingly, we sometimes need @Any@s of other kinds, such as @(* -> *)@ etc.+-- 	This is a bit like tuples.   We define a couple of useful ones here,+-- 	and make others up on the fly.  If any of these others end up being exported+-- 	into interface files, we\'ll get a crash; at least until we add interface-file+-- 	syntax to support them. ++data Any a++-- | The function @unsafeCoerce\#@ allows you to side-step the typechecker entirely. That+-- 	is, it allows you to coerce any type into any other type. If you use this function,+-- 	you had better get it right, otherwise segmentation faults await. It is generally+-- 	used when you want to write a program that you know is well-typed, but where Haskell\'s+-- 	type system is not expressive enough to prove that it is well typed.+-- +--         The following uses of @unsafeCoerce\#@ are supposed to work (i.e. not lead to+--         spurious compile-time or run-time crashes):+-- +--          * Casting any lifted type to @Any@+-- +--          * Casting @Any@ back to the real type+-- +--          * Casting an unboxed type to another unboxed type of the same size+--            (but not coercions between floating-point and integral types)+-- +--          * Casting between two types that have the same runtime representation.  One case is when+--            the two types differ only in \"phantom\" type parameters, for example+--            @Ptr Int@ to @Ptr Float@, or @[Int]@ to @[Float]@ when the list is +--            known to be empty.  Also, a @newtype@ of a type @T@ has the same representation+--            at runtime as @T@.+-- +--         Other uses of @unsafeCoerce\#@ are undefined.  In particular, you should not use+-- 	@unsafeCoerce\#@ to cast a T to an algebraic data type D, unless T is also+-- 	an algebraic data type.  For example, do not cast @Int->Int@ to @Bool@, even if+--         you later cast that @Bool@ back to @Int->Int@ before applying it.  The reasons+--         have to do with GHC\'s internal representation details (for the congnoscenti, data values+-- 	can be entered but function closures cannot).  If you want a safe type to cast things+-- 	to, use @Any@, which is not an algebraic data type.+-- 	+--         ++unsafeCoerce# :: a -> b+unsafeCoerce# = let x = x in x+++
+ lib/ghc-prim/GHC/PrimopWrappers.hs view
@@ -0,0 +1,944 @@+{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, CPP #-}+module GHC.PrimopWrappers where+import qualified GHC.Prim+import GHC.Bool (Bool)+import GHC.Unit ()+import GHC.Prim (Char#, Int#, Word#, Int64#, Word64#, Float#, Double#, ByteArray#, State#, MutableArray#, Array#, MutableByteArray#, Addr#, StablePtr#, MutVar#, RealWorld, TVar#, MVar#, ThreadId#, Weak#, StableName#, BCO#)+++#if WORD_SIZE   == 4+#define INT64 Int64#+#define WORD64 Word64#+#elif WORD_SIZE == 8+#define INT64 Int#+#define WORD64 Word#+#endif+++{-# NOINLINE gtChar# #-}+gtChar# :: Char# -> Char# -> Bool+gtChar# a1 a2 = (GHC.Prim.gtChar#) a1 a2+{-# NOINLINE geChar# #-}+geChar# :: Char# -> Char# -> Bool+geChar# a1 a2 = (GHC.Prim.geChar#) a1 a2+{-# NOINLINE eqChar# #-}+eqChar# :: Char# -> Char# -> Bool+eqChar# a1 a2 = (GHC.Prim.eqChar#) a1 a2+{-# NOINLINE neChar# #-}+neChar# :: Char# -> Char# -> Bool+neChar# a1 a2 = (GHC.Prim.neChar#) a1 a2+{-# NOINLINE ltChar# #-}+ltChar# :: Char# -> Char# -> Bool+ltChar# a1 a2 = (GHC.Prim.ltChar#) a1 a2+{-# NOINLINE leChar# #-}+leChar# :: Char# -> Char# -> Bool+leChar# a1 a2 = (GHC.Prim.leChar#) a1 a2+{-# NOINLINE ord# #-}+ord# :: Char# -> Int#+ord# a1 = (GHC.Prim.ord#) a1+{-# NOINLINE (+#) #-}+(+#) :: Int# -> Int# -> Int#+(+#) a1 a2 = (GHC.Prim.+#) a1 a2+{-# NOINLINE (-#) #-}+(-#) :: Int# -> Int# -> Int#+(-#) a1 a2 = (GHC.Prim.-#) a1 a2+{-# NOINLINE (*#) #-}+(*#) :: Int# -> Int# -> Int#+(*#) a1 a2 = (GHC.Prim.*#) a1 a2+{-# NOINLINE mulIntMayOflo# #-}+mulIntMayOflo# :: Int# -> Int# -> Int#+mulIntMayOflo# a1 a2 = (GHC.Prim.mulIntMayOflo#) a1 a2+{-# NOINLINE quotInt# #-}+quotInt# :: Int# -> Int# -> Int#+quotInt# a1 a2 = (GHC.Prim.quotInt#) a1 a2+{-# NOINLINE remInt# #-}+remInt# :: Int# -> Int# -> Int#+remInt# a1 a2 = (GHC.Prim.remInt#) a1 a2+{-# NOINLINE gcdInt# #-}+gcdInt# :: Int# -> Int# -> Int#+gcdInt# a1 a2 = (GHC.Prim.gcdInt#) a1 a2+{-# NOINLINE negateInt# #-}+negateInt# :: Int# -> Int#+negateInt# a1 = (GHC.Prim.negateInt#) a1+{-# NOINLINE addIntC# #-}+addIntC# :: Int# -> Int# -> (# Int#,Int# #)+addIntC# a1 a2 = (GHC.Prim.addIntC#) a1 a2+{-# NOINLINE subIntC# #-}+subIntC# :: Int# -> Int# -> (# Int#,Int# #)+subIntC# a1 a2 = (GHC.Prim.subIntC#) a1 a2+{-# NOINLINE (>#) #-}+(>#) :: Int# -> Int# -> Bool+(>#) a1 a2 = (GHC.Prim.>#) a1 a2+{-# NOINLINE (>=#) #-}+(>=#) :: Int# -> Int# -> Bool+(>=#) a1 a2 = (GHC.Prim.>=#) a1 a2+{-# NOINLINE (==#) #-}+(==#) :: Int# -> Int# -> Bool+(==#) a1 a2 = (GHC.Prim.==#) a1 a2+{-# NOINLINE (/=#) #-}+(/=#) :: Int# -> Int# -> Bool+(/=#) a1 a2 = (GHC.Prim./=#) a1 a2+{-# NOINLINE (<#) #-}+(<#) :: Int# -> Int# -> Bool+(<#) a1 a2 = (GHC.Prim.<#) a1 a2+{-# NOINLINE (<=#) #-}+(<=#) :: Int# -> Int# -> Bool+(<=#) a1 a2 = (GHC.Prim.<=#) a1 a2+{-# NOINLINE chr# #-}+chr# :: Int# -> Char#+chr# a1 = (GHC.Prim.chr#) a1+{-# NOINLINE int2Word# #-}+int2Word# :: Int# -> Word#+int2Word# a1 = (GHC.Prim.int2Word#) a1+{-# NOINLINE int2Float# #-}+int2Float# :: Int# -> Float#+int2Float# a1 = (GHC.Prim.int2Float#) a1+{-# NOINLINE int2Double# #-}+int2Double# :: Int# -> Double#+int2Double# a1 = (GHC.Prim.int2Double#) a1+{-# NOINLINE int2Integer# #-}+int2Integer# :: Int# -> (# Int#,ByteArray# #)+int2Integer# a1 = (GHC.Prim.int2Integer#) a1+{-# NOINLINE uncheckedIShiftL# #-}+uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftL# a1 a2 = (GHC.Prim.uncheckedIShiftL#) a1 a2+{-# NOINLINE uncheckedIShiftRA# #-}+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRA# a1 a2 = (GHC.Prim.uncheckedIShiftRA#) a1 a2+{-# NOINLINE uncheckedIShiftRL# #-}+uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedIShiftRL# a1 a2 = (GHC.Prim.uncheckedIShiftRL#) a1 a2+{-# NOINLINE plusWord# #-}+plusWord# :: Word# -> Word# -> Word#+plusWord# a1 a2 = (GHC.Prim.plusWord#) a1 a2+{-# NOINLINE minusWord# #-}+minusWord# :: Word# -> Word# -> Word#+minusWord# a1 a2 = (GHC.Prim.minusWord#) a1 a2+{-# NOINLINE timesWord# #-}+timesWord# :: Word# -> Word# -> Word#+timesWord# a1 a2 = (GHC.Prim.timesWord#) a1 a2+{-# NOINLINE quotWord# #-}+quotWord# :: Word# -> Word# -> Word#+quotWord# a1 a2 = (GHC.Prim.quotWord#) a1 a2+{-# NOINLINE remWord# #-}+remWord# :: Word# -> Word# -> Word#+remWord# a1 a2 = (GHC.Prim.remWord#) a1 a2+{-# NOINLINE and# #-}+and# :: Word# -> Word# -> Word#+and# a1 a2 = (GHC.Prim.and#) a1 a2+{-# NOINLINE or# #-}+or# :: Word# -> Word# -> Word#+or# a1 a2 = (GHC.Prim.or#) a1 a2+{-# NOINLINE xor# #-}+xor# :: Word# -> Word# -> Word#+xor# a1 a2 = (GHC.Prim.xor#) a1 a2+{-# NOINLINE not# #-}+not# :: Word# -> Word#+not# a1 = (GHC.Prim.not#) a1+{-# NOINLINE uncheckedShiftL# #-}+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftL# a1 a2 = (GHC.Prim.uncheckedShiftL#) a1 a2+{-# NOINLINE uncheckedShiftRL# #-}+uncheckedShiftRL# :: Word# -> Int# -> Word#+uncheckedShiftRL# a1 a2 = (GHC.Prim.uncheckedShiftRL#) a1 a2+{-# NOINLINE word2Int# #-}+word2Int# :: Word# -> Int#+word2Int# a1 = (GHC.Prim.word2Int#) a1+{-# NOINLINE word2Integer# #-}+word2Integer# :: Word# -> (# Int#,ByteArray# #)+word2Integer# a1 = (GHC.Prim.word2Integer#) a1+{-# NOINLINE gtWord# #-}+gtWord# :: Word# -> Word# -> Bool+gtWord# a1 a2 = (GHC.Prim.gtWord#) a1 a2+{-# NOINLINE geWord# #-}+geWord# :: Word# -> Word# -> Bool+geWord# a1 a2 = (GHC.Prim.geWord#) a1 a2+{-# NOINLINE eqWord# #-}+eqWord# :: Word# -> Word# -> Bool+eqWord# a1 a2 = (GHC.Prim.eqWord#) a1 a2+{-# NOINLINE neWord# #-}+neWord# :: Word# -> Word# -> Bool+neWord# a1 a2 = (GHC.Prim.neWord#) a1 a2+{-# NOINLINE ltWord# #-}+ltWord# :: Word# -> Word# -> Bool+ltWord# a1 a2 = (GHC.Prim.ltWord#) a1 a2+{-# NOINLINE leWord# #-}+leWord# :: Word# -> Word# -> Bool+leWord# a1 a2 = (GHC.Prim.leWord#) a1 a2+{-# NOINLINE narrow8Int# #-}+narrow8Int# :: Int# -> Int#+narrow8Int# a1 = (GHC.Prim.narrow8Int#) a1+{-# NOINLINE narrow16Int# #-}+narrow16Int# :: Int# -> Int#+narrow16Int# a1 = (GHC.Prim.narrow16Int#) a1+{-# NOINLINE narrow32Int# #-}+narrow32Int# :: Int# -> Int#+narrow32Int# a1 = (GHC.Prim.narrow32Int#) a1+{-# NOINLINE narrow8Word# #-}+narrow8Word# :: Word# -> Word#+narrow8Word# a1 = (GHC.Prim.narrow8Word#) a1+{-# NOINLINE narrow16Word# #-}+narrow16Word# :: Word# -> Word#+narrow16Word# a1 = (GHC.Prim.narrow16Word#) a1+{-# NOINLINE narrow32Word# #-}+narrow32Word# :: Word# -> Word#+narrow32Word# a1 = (GHC.Prim.narrow32Word#) a1+{-# NOINLINE plusInteger# #-}+plusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+plusInteger# a1 a2 a3 a4 = (GHC.Prim.plusInteger#) a1 a2 a3 a4+{-# NOINLINE minusInteger# #-}+minusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+minusInteger# a1 a2 a3 a4 = (GHC.Prim.minusInteger#) a1 a2 a3 a4+{-# NOINLINE timesInteger# #-}+timesInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+timesInteger# a1 a2 a3 a4 = (GHC.Prim.timesInteger#) a1 a2 a3 a4+{-# NOINLINE gcdInteger# #-}+gcdInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+gcdInteger# a1 a2 a3 a4 = (GHC.Prim.gcdInteger#) a1 a2 a3 a4+{-# NOINLINE gcdIntegerInt# #-}+gcdIntegerInt# :: Int# -> ByteArray# -> Int# -> Int#+gcdIntegerInt# a1 a2 a3 = (GHC.Prim.gcdIntegerInt#) a1 a2 a3+{-# NOINLINE divExactInteger# #-}+divExactInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+divExactInteger# a1 a2 a3 a4 = (GHC.Prim.divExactInteger#) a1 a2 a3 a4+{-# NOINLINE quotInteger# #-}+quotInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+quotInteger# a1 a2 a3 a4 = (GHC.Prim.quotInteger#) a1 a2 a3 a4+{-# NOINLINE remInteger# #-}+remInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+remInteger# a1 a2 a3 a4 = (GHC.Prim.remInteger#) a1 a2 a3 a4+{-# NOINLINE cmpInteger# #-}+cmpInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int#+cmpInteger# a1 a2 a3 a4 = (GHC.Prim.cmpInteger#) a1 a2 a3 a4+{-# NOINLINE cmpIntegerInt# #-}+cmpIntegerInt# :: Int# -> ByteArray# -> Int# -> Int#+cmpIntegerInt# a1 a2 a3 = (GHC.Prim.cmpIntegerInt#) a1 a2 a3+{-# NOINLINE quotRemInteger# #-}+quotRemInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #)+quotRemInteger# a1 a2 a3 a4 = (GHC.Prim.quotRemInteger#) a1 a2 a3 a4+{-# NOINLINE divModInteger# #-}+divModInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #)+divModInteger# a1 a2 a3 a4 = (GHC.Prim.divModInteger#) a1 a2 a3 a4+{-# NOINLINE integer2Int# #-}+integer2Int# :: Int# -> ByteArray# -> Int#+integer2Int# a1 a2 = (GHC.Prim.integer2Int#) a1 a2+{-# NOINLINE integer2Word# #-}+integer2Word# :: Int# -> ByteArray# -> Word#+integer2Word# a1 a2 = (GHC.Prim.integer2Word#) a1 a2+{-# NOINLINE andInteger# #-}+andInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+andInteger# a1 a2 a3 a4 = (GHC.Prim.andInteger#) a1 a2 a3 a4+{-# NOINLINE orInteger# #-}+orInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+orInteger# a1 a2 a3 a4 = (GHC.Prim.orInteger#) a1 a2 a3 a4+{-# NOINLINE xorInteger# #-}+xorInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #)+xorInteger# a1 a2 a3 a4 = (GHC.Prim.xorInteger#) a1 a2 a3 a4+{-# NOINLINE complementInteger# #-}+complementInteger# :: Int# -> ByteArray# -> (# Int#,ByteArray# #)+complementInteger# a1 a2 = (GHC.Prim.complementInteger#) a1 a2+{-# NOINLINE (>##) #-}+(>##) :: Double# -> Double# -> Bool+(>##) a1 a2 = (GHC.Prim.>##) a1 a2+{-# NOINLINE (>=##) #-}+(>=##) :: Double# -> Double# -> Bool+(>=##) a1 a2 = (GHC.Prim.>=##) a1 a2+{-# NOINLINE (==##) #-}+(==##) :: Double# -> Double# -> Bool+(==##) a1 a2 = (GHC.Prim.==##) a1 a2+{-# NOINLINE (/=##) #-}+(/=##) :: Double# -> Double# -> Bool+(/=##) a1 a2 = (GHC.Prim./=##) a1 a2+{-# NOINLINE (<##) #-}+(<##) :: Double# -> Double# -> Bool+(<##) a1 a2 = (GHC.Prim.<##) a1 a2+{-# NOINLINE (<=##) #-}+(<=##) :: Double# -> Double# -> Bool+(<=##) a1 a2 = (GHC.Prim.<=##) a1 a2+{-# NOINLINE (+##) #-}+(+##) :: Double# -> Double# -> Double#+(+##) a1 a2 = (GHC.Prim.+##) a1 a2+{-# NOINLINE (-##) #-}+(-##) :: Double# -> Double# -> Double#+(-##) a1 a2 = (GHC.Prim.-##) a1 a2+{-# NOINLINE (*##) #-}+(*##) :: Double# -> Double# -> Double#+(*##) a1 a2 = (GHC.Prim.*##) a1 a2+{-# NOINLINE (/##) #-}+(/##) :: Double# -> Double# -> Double#+(/##) a1 a2 = (GHC.Prim./##) a1 a2+{-# NOINLINE negateDouble# #-}+negateDouble# :: Double# -> Double#+negateDouble# a1 = (GHC.Prim.negateDouble#) a1+{-# NOINLINE double2Int# #-}+double2Int# :: Double# -> Int#+double2Int# a1 = (GHC.Prim.double2Int#) a1+{-# NOINLINE double2Float# #-}+double2Float# :: Double# -> Float#+double2Float# a1 = (GHC.Prim.double2Float#) a1+{-# NOINLINE expDouble# #-}+expDouble# :: Double# -> Double#+expDouble# a1 = (GHC.Prim.expDouble#) a1+{-# NOINLINE logDouble# #-}+logDouble# :: Double# -> Double#+logDouble# a1 = (GHC.Prim.logDouble#) a1+{-# NOINLINE sqrtDouble# #-}+sqrtDouble# :: Double# -> Double#+sqrtDouble# a1 = (GHC.Prim.sqrtDouble#) a1+{-# NOINLINE sinDouble# #-}+sinDouble# :: Double# -> Double#+sinDouble# a1 = (GHC.Prim.sinDouble#) a1+{-# NOINLINE cosDouble# #-}+cosDouble# :: Double# -> Double#+cosDouble# a1 = (GHC.Prim.cosDouble#) a1+{-# NOINLINE tanDouble# #-}+tanDouble# :: Double# -> Double#+tanDouble# a1 = (GHC.Prim.tanDouble#) a1+{-# NOINLINE asinDouble# #-}+asinDouble# :: Double# -> Double#+asinDouble# a1 = (GHC.Prim.asinDouble#) a1+{-# NOINLINE acosDouble# #-}+acosDouble# :: Double# -> Double#+acosDouble# a1 = (GHC.Prim.acosDouble#) a1+{-# NOINLINE atanDouble# #-}+atanDouble# :: Double# -> Double#+atanDouble# a1 = (GHC.Prim.atanDouble#) a1+{-# NOINLINE sinhDouble# #-}+sinhDouble# :: Double# -> Double#+sinhDouble# a1 = (GHC.Prim.sinhDouble#) a1+{-# NOINLINE coshDouble# #-}+coshDouble# :: Double# -> Double#+coshDouble# a1 = (GHC.Prim.coshDouble#) a1+{-# NOINLINE tanhDouble# #-}+tanhDouble# :: Double# -> Double#+tanhDouble# a1 = (GHC.Prim.tanhDouble#) a1+{-# NOINLINE (**##) #-}+(**##) :: Double# -> Double# -> Double#+(**##) a1 a2 = (GHC.Prim.**##) a1 a2+{-# NOINLINE decodeDouble# #-}+decodeDouble# :: Double# -> (# Int#,Int#,ByteArray# #)+decodeDouble# a1 = (GHC.Prim.decodeDouble#) a1+{-# NOINLINE decodeDouble_2Int# #-}+decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #)+decodeDouble_2Int# a1 = (GHC.Prim.decodeDouble_2Int#) a1+{-# NOINLINE gtFloat# #-}+gtFloat# :: Float# -> Float# -> Bool+gtFloat# a1 a2 = (GHC.Prim.gtFloat#) a1 a2+{-# NOINLINE geFloat# #-}+geFloat# :: Float# -> Float# -> Bool+geFloat# a1 a2 = (GHC.Prim.geFloat#) a1 a2+{-# NOINLINE eqFloat# #-}+eqFloat# :: Float# -> Float# -> Bool+eqFloat# a1 a2 = (GHC.Prim.eqFloat#) a1 a2+{-# NOINLINE neFloat# #-}+neFloat# :: Float# -> Float# -> Bool+neFloat# a1 a2 = (GHC.Prim.neFloat#) a1 a2+{-# NOINLINE ltFloat# #-}+ltFloat# :: Float# -> Float# -> Bool+ltFloat# a1 a2 = (GHC.Prim.ltFloat#) a1 a2+{-# NOINLINE leFloat# #-}+leFloat# :: Float# -> Float# -> Bool+leFloat# a1 a2 = (GHC.Prim.leFloat#) a1 a2+{-# NOINLINE plusFloat# #-}+plusFloat# :: Float# -> Float# -> Float#+plusFloat# a1 a2 = (GHC.Prim.plusFloat#) a1 a2+{-# NOINLINE minusFloat# #-}+minusFloat# :: Float# -> Float# -> Float#+minusFloat# a1 a2 = (GHC.Prim.minusFloat#) a1 a2+{-# NOINLINE timesFloat# #-}+timesFloat# :: Float# -> Float# -> Float#+timesFloat# a1 a2 = (GHC.Prim.timesFloat#) a1 a2+{-# NOINLINE divideFloat# #-}+divideFloat# :: Float# -> Float# -> Float#+divideFloat# a1 a2 = (GHC.Prim.divideFloat#) a1 a2+{-# NOINLINE negateFloat# #-}+negateFloat# :: Float# -> Float#+negateFloat# a1 = (GHC.Prim.negateFloat#) a1+{-# NOINLINE float2Int# #-}+float2Int# :: Float# -> Int#+float2Int# a1 = (GHC.Prim.float2Int#) a1+{-# NOINLINE expFloat# #-}+expFloat# :: Float# -> Float#+expFloat# a1 = (GHC.Prim.expFloat#) a1+{-# NOINLINE logFloat# #-}+logFloat# :: Float# -> Float#+logFloat# a1 = (GHC.Prim.logFloat#) a1+{-# NOINLINE sqrtFloat# #-}+sqrtFloat# :: Float# -> Float#+sqrtFloat# a1 = (GHC.Prim.sqrtFloat#) a1+{-# NOINLINE sinFloat# #-}+sinFloat# :: Float# -> Float#+sinFloat# a1 = (GHC.Prim.sinFloat#) a1+{-# NOINLINE cosFloat# #-}+cosFloat# :: Float# -> Float#+cosFloat# a1 = (GHC.Prim.cosFloat#) a1+{-# NOINLINE tanFloat# #-}+tanFloat# :: Float# -> Float#+tanFloat# a1 = (GHC.Prim.tanFloat#) a1+{-# NOINLINE asinFloat# #-}+asinFloat# :: Float# -> Float#+asinFloat# a1 = (GHC.Prim.asinFloat#) a1+{-# NOINLINE acosFloat# #-}+acosFloat# :: Float# -> Float#+acosFloat# a1 = (GHC.Prim.acosFloat#) a1+{-# NOINLINE atanFloat# #-}+atanFloat# :: Float# -> Float#+atanFloat# a1 = (GHC.Prim.atanFloat#) a1+{-# NOINLINE sinhFloat# #-}+sinhFloat# :: Float# -> Float#+sinhFloat# a1 = (GHC.Prim.sinhFloat#) a1+{-# NOINLINE coshFloat# #-}+coshFloat# :: Float# -> Float#+coshFloat# a1 = (GHC.Prim.coshFloat#) a1+{-# NOINLINE tanhFloat# #-}+tanhFloat# :: Float# -> Float#+tanhFloat# a1 = (GHC.Prim.tanhFloat#) a1+{-# NOINLINE powerFloat# #-}+powerFloat# :: Float# -> Float# -> Float#+powerFloat# a1 a2 = (GHC.Prim.powerFloat#) a1 a2+{-# NOINLINE float2Double# #-}+float2Double# :: Float# -> Double#+float2Double# a1 = (GHC.Prim.float2Double#) a1+{-# NOINLINE decodeFloat# #-}+decodeFloat# :: Float# -> (# Int#,Int#,ByteArray# #)+decodeFloat# a1 = (GHC.Prim.decodeFloat#) a1+{-# NOINLINE decodeFloat_Int# #-}+decodeFloat_Int# :: Float# -> (# Int#,Int# #)+decodeFloat_Int# a1 = (GHC.Prim.decodeFloat_Int#) a1+{-# NOINLINE newArray# #-}+newArray# :: Int# -> a -> State# s -> (# State# s,MutableArray# s a #)+newArray# a1 a2 a3 = (GHC.Prim.newArray#) a1 a2 a3+{-# NOINLINE sameMutableArray# #-}+sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool+sameMutableArray# a1 a2 = (GHC.Prim.sameMutableArray#) a1 a2+{-# NOINLINE readArray# #-}+readArray# :: MutableArray# s a -> Int# -> State# s -> (# State# s,a #)+readArray# a1 a2 a3 = (GHC.Prim.readArray#) a1 a2 a3+{-# NOINLINE writeArray# #-}+writeArray# :: MutableArray# s a -> Int# -> a -> State# s -> State# s+writeArray# a1 a2 a3 a4 = (GHC.Prim.writeArray#) a1 a2 a3 a4+{-# NOINLINE indexArray# #-}+indexArray# :: Array# a -> Int# -> (# a #)+indexArray# a1 a2 = (GHC.Prim.indexArray#) a1 a2+{-# NOINLINE unsafeFreezeArray# #-}+unsafeFreezeArray# :: MutableArray# s a -> State# s -> (# State# s,Array# a #)+unsafeFreezeArray# a1 a2 = (GHC.Prim.unsafeFreezeArray#) a1 a2+{-# NOINLINE unsafeThawArray# #-}+unsafeThawArray# :: Array# a -> State# s -> (# State# s,MutableArray# s a #)+unsafeThawArray# a1 a2 = (GHC.Prim.unsafeThawArray#) a1 a2+{-# NOINLINE newByteArray# #-}+newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newByteArray# a1 a2 = (GHC.Prim.newByteArray#) a1 a2+{-# NOINLINE newPinnedByteArray# #-}+newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newPinnedByteArray# a1 a2 = (GHC.Prim.newPinnedByteArray#) a1 a2+{-# NOINLINE newAlignedPinnedByteArray# #-}+newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+newAlignedPinnedByteArray# a1 a2 a3 = (GHC.Prim.newAlignedPinnedByteArray#) a1 a2 a3+{-# NOINLINE byteArrayContents# #-}+byteArrayContents# :: ByteArray# -> Addr#+byteArrayContents# a1 = (GHC.Prim.byteArrayContents#) a1+{-# NOINLINE sameMutableByteArray# #-}+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool+sameMutableByteArray# a1 a2 = (GHC.Prim.sameMutableByteArray#) a1 a2+{-# NOINLINE unsafeFreezeByteArray# #-}+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #)+unsafeFreezeByteArray# a1 a2 = (GHC.Prim.unsafeFreezeByteArray#) a1 a2+{-# NOINLINE sizeofByteArray# #-}+sizeofByteArray# :: ByteArray# -> Int#+sizeofByteArray# a1 = (GHC.Prim.sizeofByteArray#) a1+{-# NOINLINE sizeofMutableByteArray# #-}+sizeofMutableByteArray# :: MutableByteArray# s -> Int#+sizeofMutableByteArray# a1 = (GHC.Prim.sizeofMutableByteArray#) a1+{-# NOINLINE indexCharArray# #-}+indexCharArray# :: ByteArray# -> Int# -> Char#+indexCharArray# a1 a2 = (GHC.Prim.indexCharArray#) a1 a2+{-# NOINLINE indexWideCharArray# #-}+indexWideCharArray# :: ByteArray# -> Int# -> Char#+indexWideCharArray# a1 a2 = (GHC.Prim.indexWideCharArray#) a1 a2+{-# NOINLINE indexIntArray# #-}+indexIntArray# :: ByteArray# -> Int# -> Int#+indexIntArray# a1 a2 = (GHC.Prim.indexIntArray#) a1 a2+{-# NOINLINE indexWordArray# #-}+indexWordArray# :: ByteArray# -> Int# -> Word#+indexWordArray# a1 a2 = (GHC.Prim.indexWordArray#) a1 a2+{-# NOINLINE indexAddrArray# #-}+indexAddrArray# :: ByteArray# -> Int# -> Addr#+indexAddrArray# a1 a2 = (GHC.Prim.indexAddrArray#) a1 a2+{-# NOINLINE indexFloatArray# #-}+indexFloatArray# :: ByteArray# -> Int# -> Float#+indexFloatArray# a1 a2 = (GHC.Prim.indexFloatArray#) a1 a2+{-# NOINLINE indexDoubleArray# #-}+indexDoubleArray# :: ByteArray# -> Int# -> Double#+indexDoubleArray# a1 a2 = (GHC.Prim.indexDoubleArray#) a1 a2+{-# NOINLINE indexStablePtrArray# #-}+indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a+indexStablePtrArray# a1 a2 = (GHC.Prim.indexStablePtrArray#) a1 a2+{-# NOINLINE indexInt8Array# #-}+indexInt8Array# :: ByteArray# -> Int# -> Int#+indexInt8Array# a1 a2 = (GHC.Prim.indexInt8Array#) a1 a2+{-# NOINLINE indexInt16Array# #-}+indexInt16Array# :: ByteArray# -> Int# -> Int#+indexInt16Array# a1 a2 = (GHC.Prim.indexInt16Array#) a1 a2+{-# NOINLINE indexInt32Array# #-}+indexInt32Array# :: ByteArray# -> Int# -> Int#+indexInt32Array# a1 a2 = (GHC.Prim.indexInt32Array#) a1 a2+{-# NOINLINE indexInt64Array# #-}+indexInt64Array# :: ByteArray# -> Int# -> INT64+indexInt64Array# a1 a2 = (GHC.Prim.indexInt64Array#) a1 a2+{-# NOINLINE indexWord8Array# #-}+indexWord8Array# :: ByteArray# -> Int# -> Word#+indexWord8Array# a1 a2 = (GHC.Prim.indexWord8Array#) a1 a2+{-# NOINLINE indexWord16Array# #-}+indexWord16Array# :: ByteArray# -> Int# -> Word#+indexWord16Array# a1 a2 = (GHC.Prim.indexWord16Array#) a1 a2+{-# NOINLINE indexWord32Array# #-}+indexWord32Array# :: ByteArray# -> Int# -> Word#+indexWord32Array# a1 a2 = (GHC.Prim.indexWord32Array#) a1 a2+{-# NOINLINE indexWord64Array# #-}+indexWord64Array# :: ByteArray# -> Int# -> WORD64+indexWord64Array# a1 a2 = (GHC.Prim.indexWord64Array#) a1 a2+{-# NOINLINE readCharArray# #-}+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readCharArray# a1 a2 a3 = (GHC.Prim.readCharArray#) a1 a2 a3+{-# NOINLINE readWideCharArray# #-}+readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWideCharArray# a1 a2 a3 = (GHC.Prim.readWideCharArray#) a1 a2 a3+{-# NOINLINE readIntArray# #-}+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readIntArray# a1 a2 a3 = (GHC.Prim.readIntArray#) a1 a2 a3+{-# NOINLINE readWordArray# #-}+readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWordArray# a1 a2 a3 = (GHC.Prim.readWordArray#) a1 a2 a3+{-# NOINLINE readAddrArray# #-}+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readAddrArray# a1 a2 a3 = (GHC.Prim.readAddrArray#) a1 a2 a3+{-# NOINLINE readFloatArray# #-}+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readFloatArray# a1 a2 a3 = (GHC.Prim.readFloatArray#) a1 a2 a3+{-# NOINLINE readDoubleArray# #-}+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readDoubleArray# a1 a2 a3 = (GHC.Prim.readDoubleArray#) a1 a2 a3+{-# NOINLINE readStablePtrArray# #-}+readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrArray# a1 a2 a3 = (GHC.Prim.readStablePtrArray#) a1 a2 a3+{-# NOINLINE readInt8Array# #-}+readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt8Array# a1 a2 a3 = (GHC.Prim.readInt8Array#) a1 a2 a3+{-# NOINLINE readInt16Array# #-}+readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt16Array# a1 a2 a3 = (GHC.Prim.readInt16Array#) a1 a2 a3+{-# NOINLINE readInt32Array# #-}+readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readInt32Array# a1 a2 a3 = (GHC.Prim.readInt32Array#) a1 a2 a3+{-# NOINLINE readInt64Array# #-}+readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,INT64 #)+readInt64Array# a1 a2 a3 = (GHC.Prim.readInt64Array#) a1 a2 a3+{-# NOINLINE readWord8Array# #-}+readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord8Array# a1 a2 a3 = (GHC.Prim.readWord8Array#) a1 a2 a3+{-# NOINLINE readWord16Array# #-}+readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord16Array# a1 a2 a3 = (GHC.Prim.readWord16Array#) a1 a2 a3+{-# NOINLINE readWord32Array# #-}+readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord32Array# a1 a2 a3 = (GHC.Prim.readWord32Array#) a1 a2 a3+{-# NOINLINE readWord64Array# #-}+readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,WORD64 #)+readWord64Array# a1 a2 a3 = (GHC.Prim.readWord64Array#) a1 a2 a3+{-# NOINLINE writeCharArray# #-}+writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeCharArray# a1 a2 a3 a4 = (GHC.Prim.writeCharArray#) a1 a2 a3 a4+{-# NOINLINE writeWideCharArray# #-}+writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# a1 a2 a3 a4 = (GHC.Prim.writeWideCharArray#) a1 a2 a3 a4+{-# NOINLINE writeIntArray# #-}+writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeIntArray# a1 a2 a3 a4 = (GHC.Prim.writeIntArray#) a1 a2 a3 a4+{-# NOINLINE writeWordArray# #-}+writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWordArray# a1 a2 a3 a4 = (GHC.Prim.writeWordArray#) a1 a2 a3 a4+{-# NOINLINE writeAddrArray# #-}+writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeAddrArray# a1 a2 a3 a4 = (GHC.Prim.writeAddrArray#) a1 a2 a3 a4+{-# NOINLINE writeFloatArray# #-}+writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeFloatArray# a1 a2 a3 a4 = (GHC.Prim.writeFloatArray#) a1 a2 a3 a4+{-# NOINLINE writeDoubleArray# #-}+writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeDoubleArray# a1 a2 a3 a4 = (GHC.Prim.writeDoubleArray#) a1 a2 a3 a4+{-# NOINLINE writeStablePtrArray# #-}+writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrArray# a1 a2 a3 a4 = (GHC.Prim.writeStablePtrArray#) a1 a2 a3 a4+{-# NOINLINE writeInt8Array# #-}+writeInt8Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt8Array# a1 a2 a3 a4 = (GHC.Prim.writeInt8Array#) a1 a2 a3 a4+{-# NOINLINE writeInt16Array# #-}+writeInt16Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt16Array# a1 a2 a3 a4 = (GHC.Prim.writeInt16Array#) a1 a2 a3 a4+{-# NOINLINE writeInt32Array# #-}+writeInt32Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeInt32Array# a1 a2 a3 a4 = (GHC.Prim.writeInt32Array#) a1 a2 a3 a4+{-# NOINLINE writeInt64Array# #-}+writeInt64Array# :: MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s+writeInt64Array# a1 a2 a3 a4 = (GHC.Prim.writeInt64Array#) a1 a2 a3 a4+{-# NOINLINE writeWord8Array# #-}+writeWord8Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord8Array# a1 a2 a3 a4 = (GHC.Prim.writeWord8Array#) a1 a2 a3 a4+{-# NOINLINE writeWord16Array# #-}+writeWord16Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord16Array# a1 a2 a3 a4 = (GHC.Prim.writeWord16Array#) a1 a2 a3 a4+{-# NOINLINE writeWord32Array# #-}+writeWord32Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord32Array# a1 a2 a3 a4 = (GHC.Prim.writeWord32Array#) a1 a2 a3 a4+{-# NOINLINE writeWord64Array# #-}+writeWord64Array# :: MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s+writeWord64Array# a1 a2 a3 a4 = (GHC.Prim.writeWord64Array#) a1 a2 a3 a4+{-# NOINLINE plusAddr# #-}+plusAddr# :: Addr# -> Int# -> Addr#+plusAddr# a1 a2 = (GHC.Prim.plusAddr#) a1 a2+{-# NOINLINE minusAddr# #-}+minusAddr# :: Addr# -> Addr# -> Int#+minusAddr# a1 a2 = (GHC.Prim.minusAddr#) a1 a2+{-# NOINLINE remAddr# #-}+remAddr# :: Addr# -> Int# -> Int#+remAddr# a1 a2 = (GHC.Prim.remAddr#) a1 a2+{-# NOINLINE addr2Int# #-}+addr2Int# :: Addr# -> Int#+addr2Int# a1 = (GHC.Prim.addr2Int#) a1+{-# NOINLINE int2Addr# #-}+int2Addr# :: Int# -> Addr#+int2Addr# a1 = (GHC.Prim.int2Addr#) a1+{-# NOINLINE gtAddr# #-}+gtAddr# :: Addr# -> Addr# -> Bool+gtAddr# a1 a2 = (GHC.Prim.gtAddr#) a1 a2+{-# NOINLINE geAddr# #-}+geAddr# :: Addr# -> Addr# -> Bool+geAddr# a1 a2 = (GHC.Prim.geAddr#) a1 a2+{-# NOINLINE eqAddr# #-}+eqAddr# :: Addr# -> Addr# -> Bool+eqAddr# a1 a2 = (GHC.Prim.eqAddr#) a1 a2+{-# NOINLINE neAddr# #-}+neAddr# :: Addr# -> Addr# -> Bool+neAddr# a1 a2 = (GHC.Prim.neAddr#) a1 a2+{-# NOINLINE ltAddr# #-}+ltAddr# :: Addr# -> Addr# -> Bool+ltAddr# a1 a2 = (GHC.Prim.ltAddr#) a1 a2+{-# NOINLINE leAddr# #-}+leAddr# :: Addr# -> Addr# -> Bool+leAddr# a1 a2 = (GHC.Prim.leAddr#) a1 a2+{-# NOINLINE indexCharOffAddr# #-}+indexCharOffAddr# :: Addr# -> Int# -> Char#+indexCharOffAddr# a1 a2 = (GHC.Prim.indexCharOffAddr#) a1 a2+{-# NOINLINE indexWideCharOffAddr# #-}+indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# a1 a2 = (GHC.Prim.indexWideCharOffAddr#) a1 a2+{-# NOINLINE indexIntOffAddr# #-}+indexIntOffAddr# :: Addr# -> Int# -> Int#+indexIntOffAddr# a1 a2 = (GHC.Prim.indexIntOffAddr#) a1 a2+{-# NOINLINE indexWordOffAddr# #-}+indexWordOffAddr# :: Addr# -> Int# -> Word#+indexWordOffAddr# a1 a2 = (GHC.Prim.indexWordOffAddr#) a1 a2+{-# NOINLINE indexAddrOffAddr# #-}+indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexAddrOffAddr# a1 a2 = (GHC.Prim.indexAddrOffAddr#) a1 a2+{-# NOINLINE indexFloatOffAddr# #-}+indexFloatOffAddr# :: Addr# -> Int# -> Float#+indexFloatOffAddr# a1 a2 = (GHC.Prim.indexFloatOffAddr#) a1 a2+{-# NOINLINE indexDoubleOffAddr# #-}+indexDoubleOffAddr# :: Addr# -> Int# -> Double#+indexDoubleOffAddr# a1 a2 = (GHC.Prim.indexDoubleOffAddr#) a1 a2+{-# NOINLINE indexStablePtrOffAddr# #-}+indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a+indexStablePtrOffAddr# a1 a2 = (GHC.Prim.indexStablePtrOffAddr#) a1 a2+{-# NOINLINE indexInt8OffAddr# #-}+indexInt8OffAddr# :: Addr# -> Int# -> Int#+indexInt8OffAddr# a1 a2 = (GHC.Prim.indexInt8OffAddr#) a1 a2+{-# NOINLINE indexInt16OffAddr# #-}+indexInt16OffAddr# :: Addr# -> Int# -> Int#+indexInt16OffAddr# a1 a2 = (GHC.Prim.indexInt16OffAddr#) a1 a2+{-# NOINLINE indexInt32OffAddr# #-}+indexInt32OffAddr# :: Addr# -> Int# -> Int#+indexInt32OffAddr# a1 a2 = (GHC.Prim.indexInt32OffAddr#) a1 a2+{-# NOINLINE indexInt64OffAddr# #-}+indexInt64OffAddr# :: Addr# -> Int# -> INT64+indexInt64OffAddr# a1 a2 = (GHC.Prim.indexInt64OffAddr#) a1 a2+{-# NOINLINE indexWord8OffAddr# #-}+indexWord8OffAddr# :: Addr# -> Int# -> Word#+indexWord8OffAddr# a1 a2 = (GHC.Prim.indexWord8OffAddr#) a1 a2+{-# NOINLINE indexWord16OffAddr# #-}+indexWord16OffAddr# :: Addr# -> Int# -> Word#+indexWord16OffAddr# a1 a2 = (GHC.Prim.indexWord16OffAddr#) a1 a2+{-# NOINLINE indexWord32OffAddr# #-}+indexWord32OffAddr# :: Addr# -> Int# -> Word#+indexWord32OffAddr# a1 a2 = (GHC.Prim.indexWord32OffAddr#) a1 a2+{-# NOINLINE indexWord64OffAddr# #-}+indexWord64OffAddr# :: Addr# -> Int# -> WORD64+indexWord64OffAddr# a1 a2 = (GHC.Prim.indexWord64OffAddr#) a1 a2+{-# NOINLINE readCharOffAddr# #-}+readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readCharOffAddr# a1 a2 a3 = (GHC.Prim.readCharOffAddr#) a1 a2 a3+{-# NOINLINE readWideCharOffAddr# #-}+readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWideCharOffAddr# a1 a2 a3 = (GHC.Prim.readWideCharOffAddr#) a1 a2 a3+{-# NOINLINE readIntOffAddr# #-}+readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readIntOffAddr# a1 a2 a3 = (GHC.Prim.readIntOffAddr#) a1 a2 a3+{-# NOINLINE readWordOffAddr# #-}+readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWordOffAddr# a1 a2 a3 = (GHC.Prim.readWordOffAddr#) a1 a2 a3+{-# NOINLINE readAddrOffAddr# #-}+readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readAddrOffAddr# a1 a2 a3 = (GHC.Prim.readAddrOffAddr#) a1 a2 a3+{-# NOINLINE readFloatOffAddr# #-}+readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readFloatOffAddr# a1 a2 a3 = (GHC.Prim.readFloatOffAddr#) a1 a2 a3+{-# NOINLINE readDoubleOffAddr# #-}+readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readDoubleOffAddr# a1 a2 a3 = (GHC.Prim.readDoubleOffAddr#) a1 a2 a3+{-# NOINLINE readStablePtrOffAddr# #-}+readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrOffAddr# a1 a2 a3 = (GHC.Prim.readStablePtrOffAddr#) a1 a2 a3+{-# NOINLINE readInt8OffAddr# #-}+readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt8OffAddr# a1 a2 a3 = (GHC.Prim.readInt8OffAddr#) a1 a2 a3+{-# NOINLINE readInt16OffAddr# #-}+readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt16OffAddr# a1 a2 a3 = (GHC.Prim.readInt16OffAddr#) a1 a2 a3+{-# NOINLINE readInt32OffAddr# #-}+readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readInt32OffAddr# a1 a2 a3 = (GHC.Prim.readInt32OffAddr#) a1 a2 a3+{-# NOINLINE readInt64OffAddr# #-}+readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,INT64 #)+readInt64OffAddr# a1 a2 a3 = (GHC.Prim.readInt64OffAddr#) a1 a2 a3+{-# NOINLINE readWord8OffAddr# #-}+readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord8OffAddr# a1 a2 a3 = (GHC.Prim.readWord8OffAddr#) a1 a2 a3+{-# NOINLINE readWord16OffAddr# #-}+readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord16OffAddr# a1 a2 a3 = (GHC.Prim.readWord16OffAddr#) a1 a2 a3+{-# NOINLINE readWord32OffAddr# #-}+readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord32OffAddr# a1 a2 a3 = (GHC.Prim.readWord32OffAddr#) a1 a2 a3+{-# NOINLINE readWord64OffAddr# #-}+readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,WORD64 #)+readWord64OffAddr# a1 a2 a3 = (GHC.Prim.readWord64OffAddr#) a1 a2 a3+{-# NOINLINE writeCharOffAddr# #-}+writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeCharOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeCharOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeWideCharOffAddr# #-}+writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWideCharOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeIntOffAddr# #-}+writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeIntOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeIntOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeWordOffAddr# #-}+writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWordOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWordOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeAddrOffAddr# #-}+writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeAddrOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeAddrOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeFloatOffAddr# #-}+writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeFloatOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeFloatOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeDoubleOffAddr# #-}+writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeDoubleOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeDoubleOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeStablePtrOffAddr# #-}+writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrOffAddr# a1 a2 a3 a4 = (GHC.Prim.writeStablePtrOffAddr#) a1 a2 a3 a4+{-# NOINLINE writeInt8OffAddr# #-}+writeInt8OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt8OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeInt8OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeInt16OffAddr# #-}+writeInt16OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt16OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeInt16OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeInt32OffAddr# #-}+writeInt32OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt32OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeInt32OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeInt64OffAddr# #-}+writeInt64OffAddr# :: Addr# -> Int# -> INT64 -> State# s -> State# s+writeInt64OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeInt64OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddr# #-}+writeWord8OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord8OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWord8OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeWord16OffAddr# #-}+writeWord16OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord16OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWord16OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeWord32OffAddr# #-}+writeWord32OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord32OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWord32OffAddr#) a1 a2 a3 a4+{-# NOINLINE writeWord64OffAddr# #-}+writeWord64OffAddr# :: Addr# -> Int# -> WORD64 -> State# s -> State# s+writeWord64OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWord64OffAddr#) a1 a2 a3 a4+{-# NOINLINE newMutVar# #-}+newMutVar# :: a -> State# s -> (# State# s,MutVar# s a #)+newMutVar# a1 a2 = (GHC.Prim.newMutVar#) a1 a2+{-# NOINLINE readMutVar# #-}+readMutVar# :: MutVar# s a -> State# s -> (# State# s,a #)+readMutVar# a1 a2 = (GHC.Prim.readMutVar#) a1 a2+{-# NOINLINE writeMutVar# #-}+writeMutVar# :: MutVar# s a -> a -> State# s -> State# s+writeMutVar# a1 a2 a3 = (GHC.Prim.writeMutVar#) a1 a2 a3+{-# NOINLINE sameMutVar# #-}+sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool+sameMutVar# a1 a2 = (GHC.Prim.sameMutVar#) a1 a2+{-# NOINLINE atomicModifyMutVar# #-}+atomicModifyMutVar# :: MutVar# s a -> (a -> b) -> State# s -> (# State# s,c #)+atomicModifyMutVar# a1 a2 a3 = (GHC.Prim.atomicModifyMutVar#) a1 a2 a3+{-# NOINLINE catch# #-}+catch# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+catch# a1 a2 a3 = (GHC.Prim.catch#) a1 a2 a3+{-# NOINLINE raise# #-}+raise# :: a -> b+raise# a1 = (GHC.Prim.raise#) a1+{-# NOINLINE raiseIO# #-}+raiseIO# :: a -> State# (RealWorld) -> (# State# (RealWorld),b #)+raiseIO# a1 a2 = (GHC.Prim.raiseIO#) a1 a2+{-# NOINLINE blockAsyncExceptions# #-}+blockAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+blockAsyncExceptions# a1 a2 = (GHC.Prim.blockAsyncExceptions#) a1 a2+{-# NOINLINE unblockAsyncExceptions# #-}+unblockAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+unblockAsyncExceptions# a1 a2 = (GHC.Prim.unblockAsyncExceptions#) a1 a2+{-# NOINLINE asyncExceptionsBlocked# #-}+asyncExceptionsBlocked# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+asyncExceptionsBlocked# a1 = (GHC.Prim.asyncExceptionsBlocked#) a1+{-# NOINLINE atomically# #-}+atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+atomically# a1 a2 = (GHC.Prim.atomically#) a1 a2+{-# NOINLINE retry# #-}+retry# :: State# (RealWorld) -> (# State# (RealWorld),a #)+retry# a1 = (GHC.Prim.retry#) a1+{-# NOINLINE catchRetry# #-}+catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+catchRetry# a1 a2 a3 = (GHC.Prim.catchRetry#) a1 a2 a3+{-# NOINLINE catchSTM# #-}+catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+catchSTM# a1 a2 a3 = (GHC.Prim.catchSTM#) a1 a2 a3+{-# NOINLINE check# #-}+check# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),() #)+check# a1 a2 = (GHC.Prim.check#) a1 a2+{-# NOINLINE newTVar# #-}+newTVar# :: a -> State# s -> (# State# s,TVar# s a #)+newTVar# a1 a2 = (GHC.Prim.newTVar#) a1 a2+{-# NOINLINE readTVar# #-}+readTVar# :: TVar# s a -> State# s -> (# State# s,a #)+readTVar# a1 a2 = (GHC.Prim.readTVar#) a1 a2+{-# NOINLINE writeTVar# #-}+writeTVar# :: TVar# s a -> a -> State# s -> State# s+writeTVar# a1 a2 a3 = (GHC.Prim.writeTVar#) a1 a2 a3+{-# NOINLINE sameTVar# #-}+sameTVar# :: TVar# s a -> TVar# s a -> Bool+sameTVar# a1 a2 = (GHC.Prim.sameTVar#) a1 a2+{-# NOINLINE newMVar# #-}+newMVar# :: State# s -> (# State# s,MVar# s a #)+newMVar# a1 = (GHC.Prim.newMVar#) a1+{-# NOINLINE takeMVar# #-}+takeMVar# :: MVar# s a -> State# s -> (# State# s,a #)+takeMVar# a1 a2 = (GHC.Prim.takeMVar#) a1 a2+{-# NOINLINE tryTakeMVar# #-}+tryTakeMVar# :: MVar# s a -> State# s -> (# State# s,Int#,a #)+tryTakeMVar# a1 a2 = (GHC.Prim.tryTakeMVar#) a1 a2+{-# NOINLINE putMVar# #-}+putMVar# :: MVar# s a -> a -> State# s -> State# s+putMVar# a1 a2 a3 = (GHC.Prim.putMVar#) a1 a2 a3+{-# NOINLINE tryPutMVar# #-}+tryPutMVar# :: MVar# s a -> a -> State# s -> (# State# s,Int# #)+tryPutMVar# a1 a2 a3 = (GHC.Prim.tryPutMVar#) a1 a2 a3+{-# NOINLINE sameMVar# #-}+sameMVar# :: MVar# s a -> MVar# s a -> Bool+sameMVar# a1 a2 = (GHC.Prim.sameMVar#) a1 a2+{-# NOINLINE isEmptyMVar# #-}+isEmptyMVar# :: MVar# s a -> State# s -> (# State# s,Int# #)+isEmptyMVar# a1 a2 = (GHC.Prim.isEmptyMVar#) a1 a2+{-# NOINLINE delay# #-}+delay# :: Int# -> State# s -> State# s+delay# a1 a2 = (GHC.Prim.delay#) a1 a2+{-# NOINLINE waitRead# #-}+waitRead# :: Int# -> State# s -> State# s+waitRead# a1 a2 = (GHC.Prim.waitRead#) a1 a2+{-# NOINLINE waitWrite# #-}+waitWrite# :: Int# -> State# s -> State# s+waitWrite# a1 a2 = (GHC.Prim.waitWrite#) a1 a2+{-# NOINLINE fork# #-}+fork# :: a -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+fork# a1 a2 = (GHC.Prim.fork#) a1 a2+{-# NOINLINE forkOn# #-}+forkOn# :: Int# -> a -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+forkOn# a1 a2 a3 = (GHC.Prim.forkOn#) a1 a2 a3+{-# NOINLINE killThread# #-}+killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld)+killThread# a1 a2 a3 = (GHC.Prim.killThread#) a1 a2 a3+{-# NOINLINE yield# #-}+yield# :: State# (RealWorld) -> State# (RealWorld)+yield# a1 = (GHC.Prim.yield#) a1+{-# NOINLINE myThreadId# #-}+myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+myThreadId# a1 = (GHC.Prim.myThreadId#) a1+{-# NOINLINE labelThread# #-}+labelThread# :: ThreadId# -> Addr# -> State# (RealWorld) -> State# (RealWorld)+labelThread# a1 a2 a3 = (GHC.Prim.labelThread#) a1 a2 a3+{-# NOINLINE isCurrentThreadBound# #-}+isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+isCurrentThreadBound# a1 = (GHC.Prim.isCurrentThreadBound#) a1+{-# NOINLINE noDuplicate# #-}+noDuplicate# :: State# (RealWorld) -> State# (RealWorld)+noDuplicate# a1 = (GHC.Prim.noDuplicate#) a1+{-# NOINLINE threadStatus# #-}+threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+threadStatus# a1 a2 = (GHC.Prim.threadStatus#) a1 a2+{-# NOINLINE mkWeak# #-}+mkWeak# :: o -> b -> c -> State# (RealWorld) -> (# State# (RealWorld),Weak# b #)+mkWeak# a1 a2 a3 a4 = (GHC.Prim.mkWeak#) a1 a2 a3 a4+{-# NOINLINE mkWeakForeignEnv# #-}+mkWeakForeignEnv# :: o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Weak# b #)+mkWeakForeignEnv# a1 a2 a3 a4 a5 a6 a7 = (GHC.Prim.mkWeakForeignEnv#) a1 a2 a3 a4 a5 a6 a7+{-# NOINLINE deRefWeak# #-}+deRefWeak# :: Weak# a -> State# (RealWorld) -> (# State# (RealWorld),Int#,a #)+deRefWeak# a1 a2 = (GHC.Prim.deRefWeak#) a1 a2+{-# NOINLINE finalizeWeak# #-}+finalizeWeak# :: Weak# a -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),() #) #)+finalizeWeak# a1 a2 = (GHC.Prim.finalizeWeak#) a1 a2+{-# NOINLINE touch# #-}+touch# :: o -> State# (RealWorld) -> State# (RealWorld)+touch# a1 a2 = (GHC.Prim.touch#) a1 a2+{-# NOINLINE makeStablePtr# #-}+makeStablePtr# :: a -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a #)+makeStablePtr# a1 a2 = (GHC.Prim.makeStablePtr#) a1 a2+{-# NOINLINE deRefStablePtr# #-}+deRefStablePtr# :: StablePtr# a -> State# (RealWorld) -> (# State# (RealWorld),a #)+deRefStablePtr# a1 a2 = (GHC.Prim.deRefStablePtr#) a1 a2+{-# NOINLINE eqStablePtr# #-}+eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#+eqStablePtr# a1 a2 = (GHC.Prim.eqStablePtr#) a1 a2+{-# NOINLINE makeStableName# #-}+makeStableName# :: a -> State# (RealWorld) -> (# State# (RealWorld),StableName# a #)+makeStableName# a1 a2 = (GHC.Prim.makeStableName#) a1 a2+{-# NOINLINE eqStableName# #-}+eqStableName# :: StableName# a -> StableName# a -> Int#+eqStableName# a1 a2 = (GHC.Prim.eqStableName#) a1 a2+{-# NOINLINE stableNameToInt# #-}+stableNameToInt# :: StableName# a -> Int#+stableNameToInt# a1 = (GHC.Prim.stableNameToInt#) a1+{-# NOINLINE reallyUnsafePtrEquality# #-}+reallyUnsafePtrEquality# :: a -> a -> Int#+reallyUnsafePtrEquality# a1 a2 = (GHC.Prim.reallyUnsafePtrEquality#) a1 a2+{-# NOINLINE dataToTag# #-}+dataToTag# :: a -> Int#+dataToTag# a1 = (GHC.Prim.dataToTag#) a1+{-# NOINLINE addrToHValue# #-}+addrToHValue# :: Addr# -> (# a #)+addrToHValue# a1 = (GHC.Prim.addrToHValue#) a1+{-# NOINLINE mkApUpd0# #-}+mkApUpd0# :: BCO# -> (# a #)+mkApUpd0# a1 = (GHC.Prim.mkApUpd0#) a1+{-# NOINLINE newBCO# #-}+newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO# #)+newBCO# a1 a2 a3 a4 a5 a6 = (GHC.Prim.newBCO#) a1 a2 a3 a4 a5 a6+{-# NOINLINE unpackClosure# #-}+unpackClosure# :: a -> (# Addr#,Array# b,ByteArray# #)+unpackClosure# a1 = (GHC.Prim.unpackClosure#) a1+{-# NOINLINE getApStackVal# #-}+getApStackVal# :: a -> Int# -> (# Int#,b #)+getApStackVal# a1 a2 = (GHC.Prim.getApStackVal#) a1 a2
+ lib/ghc-prim/GHC/Tuple.hs view
@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Tuple+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/ghc-prim/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  unportable+--+-- The tuple data types+--+-----------------------------------------------------------------------------++module GHC.Tuple where++-- We need Inl etc behind the scenes for the tuple definitions+import GHC.Generics ()++default () -- Double and Inteegr aren't available yet++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+data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j+data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k+data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l+data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m+data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n+data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o+data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p+data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q+ = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q+data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r+ = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r+data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s+ = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s+data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t+ = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t+data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u+ = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u+data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v+ = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v+data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w+ = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w+data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x+ = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x+data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y+ = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y+data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z+ = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z+data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__+{- Manuel says: Including one more declaration gives a segmentation fault.+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___  u___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___  u___ v___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___+-}+
+ lib/ghc-prim/GHC/Types.hs view
@@ -0,0 +1,30 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Types (Char(..), Int(..), Float(..), Double(..)) where++import GHC.Prim+-- We need Inl etc behind the scenes for the type definitions+import GHC.Generics ()++infixr 5 :++data [] a = [] | a : [a]++data Char = C# Char#++data Int = I# Int#+-- ^A fixed-precision integer type with at least the range @[-2^29 .. 2^29-1]@.+-- The exact range for a given implementation can be determined by using+-- 'Prelude.minBound' and 'Prelude.maxBound' from the 'Prelude.Bounded' class.++-- | Single-precision floating point numbers.+-- It is desirable that this type be at least equal in range and precision+-- to the IEEE single-precision type.+data Float      = F# Float#++-- | Double-precision floating point numbers.+-- It is desirable that this type be at least equal in range and precision+-- to the IEEE double-precision type.+data Double     = D# Double#+
+ lib/ghc-prim/GHC/Unit.hs view
@@ -0,0 +1,18 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Unit where++import GHC.Generics ()++default ()++{-+The Unit type is here because GHC.PrimopWrappers needs to use it in a+type signature.+-}++-- | The unit datatype @()@ has one non-undefined member, the nullary+-- constructor @()@.+data () = ()+
+ lib/ghc-prim/LICENSE view
@@ -0,0 +1,62 @@+This library (libraries/ghc-prim) is derived from code from several+sources: ++  * Code from the GHC project which is largely (c) The University of+    Glasgow, and distributable under a BSD-style license (see below),++  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+    and freely redistributable (but see the full license for+    restrictions).++The full text of these licenses is reproduced below.  All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++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.+
+ lib/ghc-prim/Setup.hs view
@@ -0,0 +1,90 @@++-- We need to do some ugly hacks here because of GHC magic++module Main (main) where++import Control.Monad+import Data.List+import Data.Maybe+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.Text+import System.Cmd+import System.FilePath+import System.Exit+import System.Directory++main :: IO ()+main = do let hooks = simpleUserHooks {+                  regHook = addPrimModule+                          $ regHook simpleUserHooks,+                  buildHook = build_primitive_sources+                            $ buildHook simpleUserHooks,+                  makefileHook = build_primitive_sources+                               $ makefileHook simpleUserHooks,+                  haddockHook = addPrimModuleForHaddock+                              $ build_primitive_sources+                              $ haddockHook simpleUserHooks }+          defaultMainWithHooks hooks++type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()++addPrimModule :: Hook a -> Hook a+addPrimModule f pd lbi uhs x =+    do let -- I'm not sure which one of these we actually need to change.+           -- It seems bad that there are two.+           pd' = addPrimModuleToPD pd+           lpd = addPrimModuleToPD (localPkgDescr lbi)+           lbi' = lbi { localPkgDescr = lpd }+       f pd' lbi' uhs x++addPrimModuleForHaddock :: Hook a -> Hook a+addPrimModuleForHaddock f pd lbi uhs x =+    do let pc = withPrograms lbi+           pc' = userSpecifyArgs "haddock" ["GHC/Prim.hs"] pc+           lbi' = lbi { withPrograms = pc' }+       f pd lbi' uhs x++addPrimModuleToPD :: PackageDescription -> PackageDescription+addPrimModuleToPD pd =+    case library pd of+    Just lib ->+        let ems = fromJust (simpleParse "GHC.Prim") : exposedModules lib+            lib' = lib { exposedModules = ems }+        in pd { library = Just lib' }+    Nothing ->+        error "Expected a library, but none found"++build_primitive_sources :: Hook a -> Hook a+build_primitive_sources f pd lbi uhs x+ = do when (compilerFlavor (compiler lbi) == GHC) $ do+          let genprimopcode = joinPath ["..", "..", "utils",+                                        "genprimopcode", "genprimopcode"]+              primops = joinPath ["..", "..", "compiler", "prelude",+                                  "primops.txt"]+              primhs = joinPath ["GHC", "Prim.hs"]+              primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]+              primhs_tmp = addExtension primhs "tmp"+              primopwrappers_tmp = addExtension primopwrappers "tmp"+          maybeExit $ system (genprimopcode ++ " --make-haskell-source < "+                           ++ primops ++ " > " ++ primhs_tmp)+          maybeUpdateFile primhs_tmp primhs+          maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "+                           ++ primops ++ " > " ++ primopwrappers_tmp)+          maybeUpdateFile primopwrappers_tmp primopwrappers+      f pd lbi uhs x++-- Replace a file only if the new version is different from the old.+-- This prevents make from doing unnecessary work after we run 'setup makefile'+maybeUpdateFile :: FilePath -> FilePath -> IO ()+maybeUpdateFile source target = do+  r <- rawSystem "cmp" ["-s" {-quiet-}, source, target]+  case r of+    ExitSuccess   -> removeFile source+    ExitFailure _ -> do exists <- doesFileExist target+                        when exists $ removeFile target+                        renameFile source target+
+ lib/ghc-prim/cbits/longlong.c view
@@ -0,0 +1,129 @@+/* -----------------------------------------------------------------------------+ * $Id: longlong.c,v 1.4 2002/12/13 14:23:42 simonmar Exp $+ *+ * (c) The GHC Team, 1998-1999+ *+ * Primitive operations over (64-bit) long longs+ * (only used on 32-bit platforms.)+ *+ * ---------------------------------------------------------------------------*/+++/*+Miscellaneous primitive operations on HsInt64 and HsWord64s.+N.B. These are not primops!++Instead of going the normal (boring) route of making the list+of primitive operations even longer to cope with operations+over 64-bit entities, we implement them instead 'out-of-line'.++The primitive ops get their own routine (in C) that implements+the operation, requiring the caller to _ccall_ out. This has+performance implications of course, but we currently don't+expect intensive use of either Int64 or Word64 types.++The exceptions to the rule are primops that cast to and from+64-bit entities (these are defined in PrimOps.h)+*/++#include "Rts.h"++#ifdef SUPPORT_LONG_LONGS++/* Relational operators */++static inline HsBool mkBool(int b) { return b ? HS_BOOL_TRUE : HS_BOOL_FALSE; }++HsBool hs_gtWord64 (HsWord64 a, HsWord64 b) {return mkBool(a >  b);}+HsBool hs_geWord64 (HsWord64 a, HsWord64 b) {return mkBool(a >= b);}+HsBool hs_eqWord64 (HsWord64 a, HsWord64 b) {return mkBool(a == b);}+HsBool hs_neWord64 (HsWord64 a, HsWord64 b) {return mkBool(a != b);}+HsBool hs_ltWord64 (HsWord64 a, HsWord64 b) {return mkBool(a <  b);}+HsBool hs_leWord64 (HsWord64 a, HsWord64 b) {return mkBool(a <= b);}++HsBool hs_gtInt64 (HsInt64 a, HsInt64 b) {return mkBool(a >  b);}+HsBool hs_geInt64 (HsInt64 a, HsInt64 b) {return mkBool(a >= b);}+HsBool hs_eqInt64 (HsInt64 a, HsInt64 b) {return mkBool(a == b);}+HsBool hs_neInt64 (HsInt64 a, HsInt64 b) {return mkBool(a != b);}+HsBool hs_ltInt64 (HsInt64 a, HsInt64 b) {return mkBool(a <  b);}+HsBool hs_leInt64 (HsInt64 a, HsInt64 b) {return mkBool(a <= b);}++/* Arithmetic operators */++HsWord64 hs_remWord64  (HsWord64 a, HsWord64 b) {return a % b;}+HsWord64 hs_quotWord64 (HsWord64 a, HsWord64 b) {return a / b;}++HsInt64 hs_remInt64    (HsInt64 a, HsInt64 b)   {return a % b;}+HsInt64 hs_quotInt64   (HsInt64 a, HsInt64 b)   {return a / b;}+HsInt64 hs_negateInt64 (HsInt64 a)              {return -a;}+HsInt64 hs_plusInt64   (HsInt64 a, HsInt64 b)   {return a + b;}+HsInt64 hs_minusInt64  (HsInt64 a, HsInt64 b)   {return a - b;}+HsInt64 hs_timesInt64  (HsInt64 a, HsInt64 b)   {return a * b;}++/* Logical operators: */++HsWord64 hs_and64      (HsWord64 a, HsWord64 b) {return a & b;}+HsWord64 hs_or64       (HsWord64 a, HsWord64 b) {return a | b;}+HsWord64 hs_xor64      (HsWord64 a, HsWord64 b) {return a ^ b;}+HsWord64 hs_not64      (HsWord64 a)             {return ~a;}++HsWord64 hs_uncheckedShiftL64   (HsWord64 a, HsInt b)    {return a << b;}+HsWord64 hs_uncheckedShiftRL64  (HsWord64 a, HsInt b)    {return a >> b;}+/* Right shifting of signed quantities is not portable in C, so+   the behaviour you'll get from using these primops depends+   on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98+*/+HsInt64  hs_uncheckedIShiftL64  (HsInt64 a,  HsInt b)    {return a << b;}+HsInt64  hs_uncheckedIShiftRA64 (HsInt64 a,  HsInt b)    {return a >> b;}+HsInt64  hs_uncheckedIShiftRL64 (HsInt64 a,  HsInt b)+                                    {return (HsInt64) ((HsWord64) a >> b);}++/* Casting between longs and longer longs.+   (the primops that cast from long longs to Integers+   expressed as macros, since these may cause some heap allocation).+*/++HsInt64  hs_intToInt64    (HsInt    i) {return (HsInt64)  i;}+HsInt    hs_int64ToInt    (HsInt64  i) {return (HsInt)    i;}+HsWord64 hs_int64ToWord64 (HsInt64  i) {return (HsWord64) i;}+HsWord64 hs_wordToWord64  (HsWord   w) {return (HsWord64) w;}+HsWord   hs_word64ToWord  (HsWord64 w) {return (HsWord)   w;}+HsInt64  hs_word64ToInt64 (HsWord64 w) {return (HsInt64)  w;}++HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da)+{ +  mp_limb_t* d;+  HsInt s;+  HsWord64 res;+  d = (mp_limb_t *)da;+  s = sa;+  switch (s) {+    case  0: res = 0;     break;+    case  1: res = d[0];  break;+    case -1: res = -(HsWord64)d[0]; break;+    default:+      res = (HsWord64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t)));+      if (s < 0) res = -res;+  }+  return res;+}++HsInt64 hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da)+{ +  mp_limb_t* d;+  HsInt s;+  HsInt64 res;+  d = (mp_limb_t *)da;+  s = (sa);+  switch (s) {+    case  0: res = 0;     break;+    case  1: res = d[0];  break;+    case -1: res = -(HsInt64)d[0]; break;+    default:+      res = (HsInt64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t)));+      if (s < 0) res = -res;+  }+  return res;+}++#endif /* SUPPORT_LONG_LONGS */
+ lib/ghc-prim/ghc-prim.cabal view
@@ -0,0 +1,30 @@+name:           ghc-prim+version:        0.1.0.0+license:        BSD3+license-file:   LICENSE+maintainer:     libraries@haskell.org+synopsis:       GHC primitives+description:+    GHC primitives.+cabal-version:  >=1.2+build-type: Custom++Library {+    if impl(ghc)+      build-depends: rts+    exposed-modules:+        GHC.Bool+        GHC.Generics+        GHC.Ordering+        GHC.PrimopWrappers+        GHC.IntWord32+        GHC.IntWord64+        GHC.Tuple+        GHC.Types+        GHC.Unit+    extensions: CPP, MagicHash, ForeignFunctionInterface, UnliftedFFITypes,+                UnboxedTuples, EmptyDataDecls, NoImplicitPrelude+    -- We need to set the package name to ghc-prim (without a version number)+    -- as it's magic.+    ghc-options: -package-name ghc-prim+}
+ lib/integer-native/LICENSE view
@@ -0,0 +1,83 @@+This library (libraries/base) is derived from code from several+sources: ++  * Code from the GHC project which is largely (c) The University of+    Glasgow, and distributable under a BSD-style license (see below),++  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+    and freely redistributable (but see the full license for+    restrictions).++  * Code from the Haskell Foreign Function Interface specification,+    which is (c) Manuel M. T. Chakravarty and freely redistributable+    (but see the full license for restrictions).++The full text of these licenses is reproduced below.  All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++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.++-----------------------------------------------------------------------------
+ lib/integer-native/Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ lib/integer-native/integer.cabal view
@@ -0,0 +1,22 @@+name:           integer+version:        0.1+license:        BSD3+license-file:   LICENSE+maintainer:     lhc@haskell.org+synopsis:       Integer library+cabal-version:  >=1.2+build-type:     Simple++Library {+   extensions: CPP, NoImplicitPrelude+   build-depends: ghc-prim+   ghc-options: -fglasgow-exts+++   Exposed-modules:+      GHC.Integer+      GHC.Integer.Internals++   Hs-source-dirs: src+   ghc-options: -package-name integer+}
+ lib/integer-native/src/GHC/Integer.hs view
@@ -0,0 +1,193 @@+module GHC.Integer+    ( Integer+    , toInt#+    , eqInteger+    , neqInteger+    , ltInteger+    , leInteger+    , gtInteger+    , geInteger+    , compareInteger+    , quotRemInteger+    , plusInteger+    , minusInteger+    , timesInteger+    , negateInteger+    , absInteger+    , signumInteger+    , smallInteger+    , quotInteger+    , remInteger+    , divModInteger+    , lcmInteger+    , gcdInteger+    , andInteger+    , orInteger+    , xorInteger+    , complementInteger+#if WORD_SIZE == 4+    , integerToWord64+    , integerToInt64+    , word64ToInteger+    , int64ToInteger+#endif+    , wordToInteger+    , integerToWord+    , floatFromInteger+    , doubleFromInteger+    ) where++import GHC.Types+import GHC.Prim+import GHC.Bool+import GHC.Ordering+import GHC.IntWord64+import GHC.Integer.Internals++toInt# :: Integer -> Int#+toInt# (Integer i) = i++eqInteger :: Integer -> Integer -> Bool+eqInteger (Integer a) (Integer b) = a ==# b++neqInteger :: Integer -> Integer -> Bool+neqInteger (Integer a) (Integer b) = a /=# b++ltInteger :: Integer -> Integer -> Bool+ltInteger (Integer a) (Integer b) = a <# b++leInteger :: Integer -> Integer -> Bool+leInteger (Integer a) (Integer b) = a <=# b++gtInteger :: Integer -> Integer -> Bool+gtInteger (Integer a) (Integer b) = a ># b++geInteger :: Integer -> Integer -> Bool+geInteger (Integer a) (Integer b) = a >=# b++compareInteger :: Integer -> Integer -> Ordering+compareInteger (Integer a) (Integer b)+    = if a ># b+      then GT+      else if a ==# b+           then EQ+           else LT++quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)+quotRemInteger (Integer a) (Integer b)+    = (# Integer (a `quotInt#` b), Integer (a `remInt#` b) #)++plusInteger :: Integer -> Integer -> Integer+plusInteger (Integer a) (Integer b) = Integer (a +# b)++minusInteger :: Integer -> Integer -> Integer+minusInteger (Integer a) (Integer b) = Integer (a -# b)++timesInteger :: Integer -> Integer -> Integer+timesInteger (Integer a) (Integer b) = Integer (a *# b)++negateInteger :: Integer -> Integer+negateInteger (Integer a) = Integer (negateInt# a)++absInteger :: Integer -> Integer+absInteger (Integer n) = Integer (if n ># 0# then n else negateInt# n)++signumInteger :: Integer -> Integer+signumInteger (Integer i)+    = if i <# 0#+      then Integer (negateInt# 1#) else if i ==# 0#+      then Integer 0#+      else Integer 1#++smallInteger :: Int# -> Integer+smallInteger i+    = Integer i++quotInteger :: Integer -> Integer -> Integer+quotInteger (Integer a) (Integer b)+    = Integer (a `quotInt#` b)++remInteger :: Integer -> Integer -> Integer+remInteger (Integer a) (Integer b)+    = Integer (a `remInt#` b)++divModInteger :: Integer -> Integer -> (# Integer, Integer #)+divModInteger (Integer a) (Integer b)+    = (# Integer (a `divInt#` b), Integer (a `modInt#` b) #)++lcmInteger :: Integer -> Integer -> Integer+lcmInteger a b = a++gcdInteger :: Integer -> Integer -> Integer+gcdInteger (Integer a) (Integer b) = Integer (a `gcdInt#` b)++andInteger :: Integer -> Integer -> Integer+andInteger (Integer a) (Integer b)+    = Integer (word2Int# (int2Word# a `and#` int2Word# b))++orInteger :: Integer -> Integer -> Integer+orInteger (Integer a) (Integer b)+    = Integer (word2Int# (int2Word# a `or#` int2Word# b))++xorInteger :: Integer -> Integer -> Integer+xorInteger (Integer a) (Integer b)+    = Integer (word2Int# (int2Word# a `xor#` int2Word# b))++complementInteger :: Integer -> Integer+complementInteger (Integer x#)+    = Integer (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))++#if WORD_SIZE == 4+integerToWord64 :: Integer -> Word64#+integerToWord64 (Integer x) = int64ToWord64# (intToInt64# x)++integerToInt64 :: Integer -> Int64#+integerToInt64 (Integer x) = intToInt64# x++word64ToInteger :: Word64# -> Integer+word64ToInteger w = Integer (int64ToInt# (word64ToInt64# w))++int64ToInteger :: Int64# -> Integer+int64ToInteger i = smallInteger (int64ToInt# i)+#endif++wordToInteger :: Word# -> Integer+wordToInteger w = Integer (word2Int# w)++integerToWord :: Integer -> Word#+integerToWord (Integer i) = int2Word# i++floatFromInteger :: Integer -> Float#+floatFromInteger (Integer i) = int2Float# i++doubleFromInteger :: Integer -> Double#+doubleFromInteger (Integer i) = int2Double# i++divInt# :: Int# -> Int# -> Int#+x# `divInt#` y#+        -- Be careful NOT to overflow if we do any additional arithmetic+        -- on the arguments...  the following  previous version of this+        -- code has problems with overflow:+--    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#+--    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#+    = if  (x# ># 0#) && (y# <# 0#)+      then ((x# -# 1#) `quotInt#` y#) -# 1#+      else if (x# <# 0#) && (y# ># 0#)+           then ((x# +# 1#) `quotInt#` y#) -# 1#+           else x# `quotInt#` y#++modInt# :: Int# -> Int# -> Int#+x# `modInt#` y#+    = if (x# ># 0#) && (y# <# 0#) ||+         (x# <# 0#) && (y# ># 0#)+      then if r# /=# 0# then r# +# y# else 0#+      else r#+    where+    r# = x# `remInt#` y#++True && True = True+_    && _    = False+otherwise = True+False || False = False+_     || _     = True+
+ lib/integer-native/src/GHC/Integer/Internals.hs view
@@ -0,0 +1,7 @@+module GHC.Integer.Internals where++import GHC.Prim+import GHC.Types++data Integer = Integer Int#+
− src/C/Arch.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}-module C.Arch(-    ArchInfo(),-    archGetPrimInfo,-    archInfo,-    archOpTy,-    stringToOpTy,-    determineArch,-    genericArchInfo,-    primitiveInfo,-    genericPrimitiveInfo-    ) where----{--    architecture specification consists of a string of form--    backend-cpu-flags--    where any of the fields may be omitted.--    valid backends are currently "ghc" and "grin", valid cpus are listed in arch/ and 'generic', and flags consist of 32 and 64-    for instance--    grin-i686--    there are only 2 ghc versions of the backend, ghc-32 and ghc-64.---}--import Char-import Data.List-import System.IO.Unsafe-import System.Info-import qualified Data.Map as Map--import C.Prims-import Options-import Util.Gen-import qualified FlagOpts as FO-import qualified Cmm.Op as Op--#include "../arch/generic.arch"-#include "../arch/i686.arch"-#include "../arch/x86_64.arch"--#include "MachDeps.h"--newtype ArchInfo = ArchInfo {-    archPrimMap :: Map.Map ExtType PrimType-}--cpu_alias s = maybe arch_error id $ lookup s' $ [-    ("unknown","generic"),-    ("amd64","x86_64"),-    ("i386","i686"),-    ("i486","i686"),-    ("i586","i686")-    ] ++ [ (n,n) | n <- archs ] where s' = map toLower s--archs = ["generic","i686","x86_64"]--arch_map = [-    ("generic",Nothing,arch_generic,[]),-    ("i686",Nothing,arch_i686,[]),-    ("x86_64",Just 64,arch_x86_64,[]),-    ("x86_64",Just (32::Int),arch_i686,["-m32"])-    ]--available_archs = snub $ "ghc":"ghc-64":"ghc-32":[ n | (n,_,_,_) <- arch_map ]  ++ [ n ++ "-" ++ show b |  (n,Just b,_,_) <- arch_map]---- get information on a primitive type if it is available-archGetPrimInfo :: Monad m => ArchInfo -> ExtType -> m PrimType-archGetPrimInfo ArchInfo { archPrimMap = pi } et = case Map.lookup et pi of-    Nothing -> fail $ "archGetPrimInfo: No info for: " ++ et-    Just s -> return s--primitiveInfo :: Monad m => ExtType -> m PrimType-primitiveInfo et = archGetPrimInfo archInfo et--genericPrimitiveInfo :: Monad m => ExtType -> m PrimType-genericPrimitiveInfo et = archGetPrimInfo genericArchInfo et--genericArchInfo = ArchInfo { archPrimMap = primMap }-archInfo = ArchInfo { archPrimMap = genericPrimMap }--primMap :: Map.Map ExtType PrimType-primMap = Map.fromList [ (primTypeName a,a) | a <- as ] where-    (_,as,_) = unsafePerformIO determineArch--genericPrimMap :: Map.Map ExtType PrimType-genericPrimMap = Map.fromList [ (primTypeName a,a) | a <- arch_generic ] where--stringToOpTy = archOpTy genericArchInfo--archOpTy :: ArchInfo -> ExtType -> Op.Ty-archOpTy ai s = case Op.readTy s of-    Just t -> t-    _ -> error $ "archOpTy: " ++ show s---    Nothing -> case archGetPrimInfo ai s of---        Nothing -> f s---        Just pt -> case primTypeType pt of---            PrimTypeIntegral -> Op.TyBits (Op.Bits $ 8 * primTypeSizeOf pt) (if primTypeIsSigned pt then Op.HintSigned else Op.HintUnsigned)---            PrimTypeFloating ->  Op.TyBits (Op.Bits $ 8 * primTypeSizeOf pt) Op.HintFloat---            _ -> f s---  where---    f "float" = Op.TyBits  (Op.Bits 32) Op.HintFloat---    f "double" = Op.TyBits (Op.Bits 64) Op.HintFloat---    f "int" = Op.TyBits (Op.BitsArch Op.BitsInt) Op.HintSigned---    f "unsigned int" = Op.TyBits (Op.BitsArch Op.BitsInt) Op.HintUnsigned------    f "uintmax_t" = Op.TyBits (Op.BitsArch Op.BitsMax) Op.HintUnsigned---    f "intmax_t" = Op.TyBits (Op.BitsArch Op.BitsMax)  Op.HintSigned---    f "uintptr_t" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintUnsigned---    f "intptr_t" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintSigned---    f "HsPtr" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintUnsigned---    f "HsFunPtr" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintUnsigned---    f s = Op.TyBits (Op.BitsExt s) Op.HintNone----determineArch = do-    let specs = maybe [] (split (== '-')) (optArch options)-        (cpu,bits) = case specs of-            ["32"] -> (cpu_alias arch,32)-            ["64"] -> (cpu_alias arch,64)-            [cpu,"32"] -> (cpu_alias cpu,32)-            [cpu,"64"] -> (cpu_alias cpu,64)-            [cpu]      -> (cpu_alias cpu,WORD_SIZE_IN_BITS)-            []         -> (cpu_alias arch,WORD_SIZE_IN_BITS)-            _          -> arch_error-    let (fn,mp,opt) = case (cpu,bits) of-            ("generic",_) -> ("generic",arch_generic,[])-            ("i686",32)   -> ("i686",arch_i686,[])-            ("x86_64",32) -> ("x86_64-32",arch_i686, ["-m32"])-            ("x86_64",(64::Int)) -> ("x86_64",arch_x86_64,[])-            _ -> arch_error--    return (fn,mp,opt)--arch_error =  error $ "\nunknown architecture, supported architectures are:\n" ++ show available_archs
− src/C/FFI.hs 
@@ -1,53 +0,0 @@-module C.FFI(-    CallConv(..),-    Safety(..),-    FfiType(..),-    FfiExport(..),-    FfiSpec(..),-    Requires(..)-    ) where-import Data.Typeable-import Data.DeriveTH-import Data.Derive.All-import Data.Binary-import Data.Monoid-import Control.Monad--type CName    = String--data CallConv = CCall | StdCall | Primitive | DotNet deriving(Eq,Ord,Show)-$(derive makeBinary ''CallConv)--data Safety = Safe | Unsafe deriving(Eq,Ord,Show)-$(derive makeBinary ''Safety)---data Requires = Requires {-    reqIncludes :: [String],-    reqLibraries :: [String]-    } deriving(Eq, Ord)--instance Show Requires where-    show (Requires [] []) = "()"-    show (Requires xs ys) = show (xs,ys)---- we have to put these after so the instances go in order-$(derive makeBinary ''Requires)-$(derive makeMonoid ''Requires)--data FfiType = Import CName Requires-             | ImportAddr CName Requires-             | Wrapper-             | Dynamic-             deriving(Eq,Ord,Show)-$(derive makeBinary ''FfiType)---data FfiSpec = FfiSpec FfiType Safety CallConv-             deriving(Eq,Ord,Show)-$(derive makeBinary ''FfiSpec)--data FfiExport = FfiExport CName Safety CallConv-             deriving(Eq,Ord,Show,Typeable)-$(derive makeBinary ''FfiExport)-
− src/C/FromGrin2.hs 
@@ -1,892 +0,0 @@--module C.FromGrin2(compileGrin) where--import Control.Monad.Identity-import Control.Monad.RWS-import System.IO.Unsafe-import Data.List-import Data.Char-import Data.Maybe-import Data.Monoid-import Text.PrettyPrint.ANSI.Leijen(indent,(<$$>))-import Text.Printf-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Text.PrettyPrint.ANSI.Leijen as P--import Data.DeriveTH-import Data.Derive.All--import C.Arch-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 RawFiles-import StringTable.Atom-import Support.CanType-import Support.FreeVars-import Util.Gen-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,-    wEnums :: Map.Map Name Int,-    wFunctions :: Map.Map Name Function-    }-$(derive makeMonoid ''Written)--data Env = Env {-    rTodo :: Todo,-    rInscope :: Set.Set Name,-    rDeclare :: Bool,-    rEMap :: Map.Map Atom (Name,[Expression]),-    rCPR  :: Set.Set Atom,-    rGrin :: Grin-    }-$(derive makeUpdate ''Env)---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)-runC grin (C m) =  execUniq1 (runRWST m Env { rCPR = cpr, rGrin = grin, rDeclare = False, rTodo = TodoExp [], rEMap = mempty, rInscope = mempty } emptyHcHash) where-    TyEnv tmap = grinTypeEnv grin-    -- This controls the use of unboxed but tagged representations of types via VALUE and GETVALUE-    -- Int and Word used to be included when -ffull-int was not on, but we don't want that at this time-    cpr = Set.insert cChar (Set.fromList [ a | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) -                                                 <- Map.assocs tmap, a == a', isJust (good s) ])-    good s = do-        ct <- Op.toCmmTy s-        b <- Op.cmmTyBits ct-        guard $ b <= 30-        Op.HintNone <- Op.cmmTyHint ct-        return True--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 -> (String,[String])-compileGrin grin = (hsffi_h ++ lhc_rts_header_h ++ lhc_rts_alloc_c ++ lhc_rts_c ++ lhc_rts2_c ++ generateArchAssertions ++ show ans ++ "\n", snub (reqLibraries req))  where-    ans = vcat $ includes ++ [text "", enum_tag_t, header, cafs,buildConstants grin finalHcHash, body] :: P.Doc-    includes =  map include (snub $ reqIncludes req)-    include fn = text "#include <" <> text fn <> text ">"-    (header,body) = generateC (Map.elems fm) (Map.elems sm)-    ((),finalHcHash,Written { wRequires = req, wFunctions = fm, wEnums = wenum, wStructures = sm, wTags = ts }) = runC grin go-    enum_tag_t | null enums = mempty-               | otherwise  = text "enum {" <$$> indent 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 (Map.lookup 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 $ map ccaf (grinCafs grin))--convertFunc :: Maybe (FfiExport, ([ExtType], ExtType)) -> (Atom,Lam) -> C [Function]-convertFunc ffie (n,as :-> body) = do-        s <- localTodo TodoReturn (convertBody body)-        let bt = getType body-            mmalloc [TyPtr TyNode] = [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 $-                                      zipWith cast (map snd as')-                                                   (map variable newVars))]--        return (function fnname fr as' ats (profile_function_inc & 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 rCPR-        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 rCPR-        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 (APrim 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 (APrim 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 (TyPtr TyNode) = return sptr_t-convertType (TyPtr (TyPtr TyNode)) = return $ ptrType sptr_t-convertType ~(TyPrim opty) = return (opTyToC opty)--tyToC _ Op.TyBool = "bool"-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"---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@(Var _ ty) [[p1@(NodeC t fps)] :-> e1,[p2] :-> e2]) | ty == TyNode = do-    scrut <- convertVal v-    cpr <- asks rCPR-    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-        {--        da (NodeC t [a]) e | t `Set.member` cpr = do-            a' <- iDeclare $ convertVal a-            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-            e' <- convertBody e-            return (ass & e')-        da ~(NodeC t as) e = do-            tellTags t-            declareStruct t-            as' <- iDeclare $ mapM convertVal as-            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-            e' <- convertBody e-            return (ass & 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)-        tag = f_GETWHAT scrut-        ifscrut = if null fps then f_RAWWHAT tenum `eq` scrut else tenum `eq` tag where-            tenum = (constant $ enum (nodeTagName t))-    p1' <- da p1 e1-    p2' <- am p2 =<< da p2 e2-    return $ profile_case_inc & 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@Var {} [v1, v2@([Lit n _] :-> _)]) | n == 0 = convertBody (Case v [v2,v1])-convertBody (Case v@(Var _ 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 $ profile_case_inc & cif (cp p1 `eq` scrut) e1' (am e2')-convertBody (Case v@(Var _ t) ls) | t == TyNode = do-    scrut <- convertVal v-    let tag = f_GETWHAT 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 $ profile_case_inc & switch' tag ls'-convertBody (Case v@(Var _ t) 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 $ profile_case_inc & switch' scrut ls'-convertBody (Error s t) = do-    x <- asks rTodo-    let jerr | null s    = toStatement $ functionCall (name "lhc_exit") [constant $ number 255]-             | otherwise = toStatement $ functionCall (name "lhc_error") [string s]-    let f (TyPtr _) = return nullPtr-        f TyNode = 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 (Store  n@NodeC {})  = newNode sptr_t n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v)-convertBody (Return [n@NodeC {}])  = newNode wptr_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 (Update (Index base off) z) | getType base == TyPtr tyINode = do-    base <- convertVal base-    off <- convertVal off-    z' <- convertVal z-    return $ indexArray base off =* z'-convertBody (Fetch (Index base off)) | getType base == TyPtr tyINode = do-    base <- convertVal base-    off <- convertVal off-    simpleRet (indexArray base off)---- return, promote and demote-convertBody (Fetch v)        | getType v == tyINode = simpleRet =<< f_promote `liftM` convertVal v-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' = cna where-    cna = do-        cpr <- asks rCPR-        if t `Set.notMember` cpr then na else do-        v' <- convertVal v-        [arg] <- return as-        t <- convertType $ getType arg-        arg' <- iDeclare $ convertVal arg-        let s = arg' =* cast t (f_GETVALUE v')-        ss <- convertBody e'-        return $ s & ss-    na = do-        declareStruct t-        v' <- convertVal v-        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 Return {} = False-isCompound Store {} = False-isCompound Prim {} = False-isCompound _ = True---convertExp :: Exp -> C (Statement,Expression)-convertExp (Prim p vs ty) | APrim _ req <- p  =  do-    tell mempty { wRequires = req }-    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 (App a [v] _) | a == funcEval = do-    v' <- convertVal v-    return (mempty,f_eval v')-convertExp (App a vs _) = do-    lm <- asks rEMap-    vs' <- mapM convertVal vs-    case a `Map.lookup` 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)) vs')-convertExp (Update v@(Var vv _) tn@(NodeC t as)) | getType v == TyPtr TyNode = do-    v' <- convertVal v-    as' <- mapM convertVal as-    nt <- nodeTypePtr t-    let tmp' = cast nt (f_DETAG v') -- (if vv < v0 then f_DETAG v' else v')-    if not (tagIsSuspFunction t) && vv < v0 then do-        (nns, nn) <- newNode fptr_t tn-        return (nns & getHead (f_NODEP(f_DETAG v')) =* nn,emptyExpression)-     else do-        s <- tagAssign tmp' t-        let ass = [project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ]-        return (mconcat $ profile_update_inc:s:ass,emptyExpression)--convertExp Alloc { expValue = v, expCount = c, expRegion = r } | r == region_heap, TyPtr TyNode == getType v  = do-    v' <- convertVal v-    c' <- convertVal c-    tmp <- newVar (ptrType sptr_t)-    let malloc = tmp =* lhc_malloc (operator "*" (sizeof sptr_t) c')-    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 $ show (pprint val :: P.Doc)) <> text "*/\n" <>-     text "static node_t _" <> tshow (varName v) <> text ";\n" <>-     text "#define " <> tshow (varName v) <+>  text "(EVALTAGC(&_" <> tshow (varName v) <> text "))\n";---buildConstants 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 sibs of-            Just [a'] | a' == a -> []-            _ -> [text ".what =" <+> tshow (nodeTagName a)]-        def = text "#define c" <> tshow i <+> text "((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 . 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 $ if i == 0 then constant cFalse else constant cTrue-    f (Lit i (TyPrim (Op.TyBits _ Op.HintFloat))) = return (constant $ floating (realToFrac i))-    f (Lit i _) = return (constant $ number (fromIntegral i))-    f (ValPrim (APrim p _) [] ty) = case p of-        CConst s _ -> return $ expressionRaw 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 (APrim 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 (APrim 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-    | APrim (CConst s _) _ <- p = do-        return $ expressionRaw s-    | APrim Op {} _ <- p = do-        let [rt] = ty-        convertVal (ValPrim (p) vs rt)-    | APrim (Func _ n as r) _ <- p = do-        vs' <- mapM convertVal vs-        rt <- convertTypes ty-        return $ cast (rt) (functionCall (name $ unpackPS n) [ cast (basicType t) v | v <- vs' | t <- as ])-    | APrim (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 ])-    | APrim (Peek t) _ <- p, [v] <- vs = do-        v' <- convertVal v-        return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> char ')')-    | APrim (Poke t) _ <- p, [v,x] <- vs = do-        v' <- convertVal v-        x' <- convertVal x-        return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> text ") = " <> renderG x')-    | APrim (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 t-    return $ getHead e =* f_EVALFUNC (reference (variable en))-tagAssign e t = do-    declareStruct t-    tyenv <- asks (grinTypeEnv . rGrin)-    TyTy { tySiblings = sib } <- findTyTy tyenv t-    tellTags t-    case sib of-        Just [n'] | n' == t -> return mempty-        _ -> do return . toStatement $ f_SETWHAT 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 ty ~(NodeC t as) = do-    let sf = tagIsSuspFunction t-    bn <- basicNode t as-    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 = if not sf && all (nonPtr . getType) as then lhc_malloc_atomic else lhc_malloc-            malloc =  wmalloc (sizeof st)-            nonPtr TyPtr {} = False-            nonPtr TyNode = False---            nonPtr (TyTup xs) = all nonPtr xs-            nonPtr _ = True-        (dtmp,tmp) <- 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_EVALTAG tmp) else tmp-        return (mconcat $ dtmp:tagassign:ass,res)------------------------- declaring stuff---------------------declareStruct n = do-    grin <- asks rGrin-    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 [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 = 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_RAWWHAT (constant $ enum (nodeTagName a)))-basicNode a [v] = do-    cpr <- asks rCPR-    if a `Set.notMember` cpr then return Nothing else-        case v of-            Lit i ty | a == cChar, Just c <- ch -> return $ Just (f_VALUE (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 (f_VALUE v)-basicNode _ _ = return Nothing--instance Op.ToCmmTy Ty where-    toCmmTy (TyPrim p) = Just p-    toCmmTy _ = Nothing--declareEvalFunc n = do-    fn <- tagToFunction n-    grin <- asks rGrin-    declareStruct n-    nt <- nodeType n-    let ts = runIdentity $ findArgs (grinTypeEnv grin) n-        fname = toName $ "lhc_eval_" ++ show fn-        aname = name "arg";-        rvar = localVariable wptr_t (name "r");-        atype = ptrType nt-        body = rvar =* functionCall (toName (show $ fn)) [ project' (arg i) (variable aname) | _ <- ts | i <- [(1 :: Int) .. ] ]-        update =  f_update (cast sptr_t (variable aname)) rvar-    tellFunctions [function fname wptr_t [(aname,atype)] [a_STD, a_FALIGNED] (body & update & creturn rvar )]-    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-------------------------------lhc_malloc sz = functionCall (name "lhc_malloc") [sz]-f_assert e    = functionCall (name "assert") [e]-f_DETAG e     = functionCall (name "DETAG") [e]-f_NODEP e     = functionCall (name "NODEP") [e]-f_VALUE e     = functionCall (name "VALUE") [e]-f_GETVALUE e  = functionCall (name "GETVALUE") [e]-f_EVALTAG e   = functionCall (name "EVALTAG") [e]-f_EVALFUNC e  = functionCall (name "EVALFUNC") [e]-f_eval e      = functionCall (name "eval") [e]-f_promote e   = functionCall (name "promote") [e]-f_PROMOTE e   = functionCall (name "PROMOTE") [e]-f_GETWHAT e   = functionCall (name "GETWHAT") [e]-f_SETWHAT e v = functionCall (name "SETWHAT") [e,v]-f_RAWWHAT e   = functionCall (name "RAWWHAT") [e]-f_demote e    = functionCall (name "demote") [e]-f_follow e    = functionCall (name "follow") [e]-f_update x y  = functionCall (name "update") [x,y]-lhc_malloc_atomic sz = functionCall (name "lhc_malloc_atomic") [sz]-profile_update_inc   = toStatement $ functionCall (name "lhc_update_inc") []-profile_case_inc     = toStatement $ functionCall (name "lhc_case_inc") []-profile_function_inc = toStatement $ functionCall (name "lhc_function_inc") []--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"-fptr_t    = basicGCType "fptr_t"-wptr_t    = basicGCType "wptr_t"--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)---generateArchAssertions :: String-generateArchAssertions = unlines (h:map f (filter notVoid as) ++ [t]) where-    (_,as,_) = unsafePerformIO determineArch-    notVoid pt = primTypeName pt /= "void"-    f pt = printf "      assert(sizeof(%s) == %d);" (primTypeName pt) (primTypeSizeOf pt)-    h = "static void\nlhc_arch_assert(void)\n{"-    t = "}"----
− src/C/Generate.hs 
@@ -1,687 +0,0 @@-module C.Generate(-    Annotate(..),-    Structure(..),-    (=*),-    (&),-    ToExpression(..),-    ToStatement(..),-    eq,-    basicStructure,-    anonStructType,-    basicType,-    basicGCType,-    cast,-    noAssign,-    cif,-    constant,-    cTrue,cFalse,-    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 Char-import Control.Monad.RWS-import Control.Monad.Writer-import Control.Monad-import Data.List(intersperse)-import Data.Maybe(isNothing)-import Data.Monoid-import Numeric-import Text.PrettyPrint.ANSI.Leijen(Doc,indent,(<$$>))-import qualified Data.Foldable as Seq-import qualified Data.Map as Map-import qualified Data.Sequence as Seq-import qualified Data.Traversable as Seq-import qualified Data.Set as Set--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 '{', indent 4 s, char '}']-    draw (SIf exp thn els) = do-        exp <- draw exp-        thn <- subBlockBody thn-        els <- subBlockBody els-        return $ text "if" <+> parens exp <+> lbrace <$> indent 4 thn <$> rbrace <+> text "else" <+> lbrace <$> indent 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 ':' <$$> indent 4 (ss <$$> text "break;")-        sc (Nothing,ss) = do ss <- draw (SBlock ss); return $ text "default:"  <$$>  ( indent 4 ss <$$> text "break;")-        md = if any isNothing (fsts ts) then empty else text "default: lhc_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 :: String -> Expression -> Expression -> Expression-operator o x y = expDC (pdraw x <+> text o <+> pdraw 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---newTmpVar t e = do-    u <- newUniq-    let n = name $ 'x':show u-        d = sd $ do-            va <- draw (variable n `assign` e)-            t <- draw t-            return $ t <+> va-    return (d,variable n)--newAssignVar t n e = do-    let d = sd $ do-            va <- draw (variable n `assign` 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 <$> indent 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 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 $+$ indent 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 =  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) ""--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 <$$> indent 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 = show $ 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 :: Expression -> Expression -> Expression-eq = operator "=="--infix 2 =*--(=*) :: Expression -> Expression -> Statement-x =* y = x `assign` 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 Constant where-    toExpression c = constant c--instance ToExpression Name where-    toExpression c = variable c--instance ToExpression Char where-    toExpression c = constant $ character c---infixl 1 &--(&) :: (ToStatement a,ToStatement b) => a -> b -> Statement-x & y = toStatement x `mappend` toStatement y-
− src/C/Prims.hs 
@@ -1,184 +0,0 @@-module C.Prims where--import Data.Monoid-import Data.Typeable-import Data.Binary-import Control.Monad-import Data.DeriveTH-import Data.Derive.All-import StringTable.Atom-import C.FFI(Requires(..))-import Doc.DocLike-import Doc.PPrint-import PackedString-import qualified Cmm.Op as Op--data PrimTypeType = PrimTypeIntegral | PrimTypeFloating | PrimTypePointer | PrimTypeVoid-    deriving(Show,Eq,Ord)--data PrimType = PrimType {-    primTypeName :: ExtType,-    primTypeType :: PrimTypeType,-    primTypeAlignmentOf :: !Int,-    primTypeIsSigned :: !Bool,-    primTypeSizeOf :: !Int-    } deriving(Show)--type ExtType = String---data DotNetPrim = DotNetField | DotNetCtor | DotNetMethod-    deriving(Typeable, Eq, Ord, Show)--data Prim =-    PrimPrim Atom          -- Special primitive implemented in the compiler somehow.-    | CConst { primConst :: String, primRetType :: ExtType }  -- C code which evaluates to a constant-    | Func {-        funcIOLike :: !Bool,-        funcName :: PackedString,-        primArgTypes :: [ExtType],-        primRetType :: ExtType-        }   -- function call with C calling convention-    | IFunc {-        funcIOLike :: !Bool,-        primArgTypes :: [ExtType],-        primRetType :: ExtType-        } -- indirect function call with C calling convention-    | AddrOf 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)--data PrimTypeInfo = PrimSizeOf | PrimMaxBound | PrimMinBound | PrimAlignmentOf | PrimUMaxBound-    deriving(Typeable, Eq, Ord, Show)--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--aprimIsCheap (APrim p _) = primIsCheap p----- | 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----parsePrimString s = do-    ws@(_:_) <- return $ words s-    let v = case last ws of-            '&':s -> AddrOf (packString s)-            s -> Func False (packString s) [] ""-    let f opt@('-':'l':_) = Requires [] [opt]-        f s = Requires [s] []-    return (APrim v (mconcat (map f (init ws))))---primPrim s = APrim (PrimPrim $ toAtom s) mempty--data APrim = APrim Prim Requires-    deriving(Typeable,  Eq, Ord)---instance Show APrim where-    showsPrec n (APrim p r) | r == mempty = showsPrec n p-    showsPrec n (APrim p r) = showsPrec n p . shows r--instance PPrint d Prim  => PPrint d APrim where-    pprintPrec n (APrim p _) = pprintPrec n p--instance DocLike d => PPrint d Prim where-    pprint (PrimPrim t) = text (fromAtom t)-    pprint (CConst s t) = parens (text t) <> parens (text s)-    pprint (Func _ s xs r) = parens (text r) <> text (unpackPS s) <> tupled (map text xs)-    pprint (IFunc _ xs r) = parens (text r) <> parens (char '*') <> tupled (map text xs)-    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-    pprintPrec n p = text (showsPrec n p "")-instance (DocLike d,Show v) => PPrint d (Op.Op v) where-    pprintPrec 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"--$(derive makeBinary ''DotNetPrim)-$(derive makeBinary ''Prim)-$(derive makeBinary ''PrimTypeInfo)-$(derive makeBinary ''APrim)
− src/CharIO.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}-module CharIO(-    UTF8.putStr,-    UTF8.putStrLn,-    UTF8.hPutStrLn,-    putErr,-    putErrLn,-    putErrDie,-    UTF8.readFile,-    UTF8.print,-    UTF8.hGetContents,-) where-import Control.Exception as Ex-import System-import qualified IO-import qualified System.IO.UTF8 as UTF8--#if BASE4-flushOut = Ex.catch  (IO.hFlush IO.stdout) (\(e::SomeException) -> return ())-#else-flushOut = Ex.catch  (IO.hFlush IO.stdout) (\_ -> return ())-#endif--putErr    s  = flushOut >> UTF8.hPutStr   IO.stderr s-putErrLn  s  = flushOut >> UTF8.hPutStrLn IO.stderr s-putErrDie s  = flushOut >> UTF8.hPutStrLn IO.stderr s >> System.exitFailure
− src/Cmm/Number.hs 
@@ -1,25 +0,0 @@-module Cmm.Number(Number(..),toIntegral) where--import Ratio-import Data.Binary--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/Op.hs 
@@ -1,388 +0,0 @@-module Cmm.Op where--import Data.DeriveTH-import Data.Derive.All-import Data.Binary-import Util.Gen-import Control.Monad-{---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)--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-    deriving(Eq,Show,Ord,Read)----- 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)---data ValOp-    = NaN-    | PInf-    | NInf-    | PZero-    | NZero-    deriving(Eq,Show,Ord,Read)--data ArchBits = BitsMax | BitsPtr | BitsUnknown-    deriving(Eq,Ord)---data TyBits = Bits !Int | BitsArch !ArchBits |  BitsExt String-    deriving(Eq,Ord)--data TyHint-    = HintSigned-    | HintUnsigned-    | HintFloat        -- an IEEE floating point value-    | HintCharacter    -- a unicode character, implies unsigned-    | HintNone         -- no hint-    deriving(Eq,Ord)--data Ty-    = TyBits !TyBits !TyHint-    | TyBool-    deriving(Eq,Ord)---readTy :: Monad m => String -> m Ty-readTy "bool" = return TyBool-readTy "bits<ptr>" = return $ TyBits (BitsArch BitsPtr) HintNone-readTy "bits<max>" = return $ TyBits (BitsArch BitsMax) HintNone-readTy "bits<?>" = return $ TyBits (BitsArch BitsUnknown) HintNone-readTy ('b':'i':'t':'s':'<':rs) = return $ TyBits (BitsExt (takeWhile ('>' /=) rs)) HintNone-readTy ('b':'i':'t':'s':rs) = do n <- readM rs; return $ TyBits (Bits n) HintNone-readTy ('s':rs) = do TyBits x _ <- readTy rs; return $ TyBits x HintSigned-readTy ('u':rs) = do TyBits x _ <- readTy rs; return $ TyBits x HintUnsigned-readTy ('f':rs) = do TyBits x _ <- readTy rs; return $ TyBits x HintFloat-readTy ('c':rs) = do TyBits x _ <- readTy rs; return $ TyBits x HintCharacter-readTy _ = fail "readTy: not type"--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--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)---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 where--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 _ = False-    isEagerSafe (BinOp o _ _) = isEagerSafe o-    isEagerSafe (UnOp o _) = isEagerSafe o-    isEagerSafe (ConvOp o _) = isEagerSafe o-    isEagerSafe _ = False--$(derive makeBinary ''BinOp)-$(derive makeBinary ''UnOp)-$(derive makeBinary ''ConvOp)-$(derive makeBinary ''ValOp)-$(derive makeBinary ''ArchBits)-$(derive makeBinary ''TyBits)-$(derive makeBinary ''TyHint)-$(derive makeBinary ''Ty)-$(derive makeBinary ''Op)
− src/Cmm/OpEval.hs 
@@ -1,197 +0,0 @@-module Cmm.OpEval(-    Expression(..),-    convOp,-    convNumber,-    convCombine,-    binOp,-    binOp',-    unOp-    ) where--import Cmm.Number-import Cmm.Op-import Control.Monad-import Maybe---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 `tyLt` y = (x `tyLte` y) && not (y `tyLte` x)-x `tyGt` y = y `tyLt` x-x `tyGte` y = y `tyLte` x-x `tyEq` y = (x `tyLte` 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 Eq  v1 v2 = return $ toBool (v1 == v2)-    f NEq v1 v2 = return $ toBool (v1 /= v2)-    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 FPwr v1 v2 = return $ toExpression (realToFrac (realToFrac v1 ** realToFrac v2 :: Double)) str--    f op v1 v2 | Just v <- lookup op ops = return $ toBool (v1 `v` v2) where-        ops = [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)),-               (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=))]-    f op v1 v2 | Just v <- lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where-        ops = [(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 _ _ = Nothing-unOp op t1 tr e str = Nothing-
+ src/CompactString.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE BangPatterns #-}+module CompactString+    ( CompactString+    , fromString+    , fromByteString+    , fromLazyByteString+    , append+    , qualToCompact+    ) where++import Data.IORef+import qualified Data.Trie as Trie++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++import System.IO.Unsafe++import Data.Digest.CRC32+import Data.Binary+import Data.Char+import Text.PrettyPrint.ANSI.Leijen+import Control.Monad (liftM2)+import qualified Data.String as String++instance String.IsString CompactString where+    fromString = fromString -- Surprise, surprise, this is not a loop.++data CompactString = CompactString { csString :: S.ByteString+                                   , csHash   :: Word32 }++instance Binary CompactString where+    put cs = put (csString cs) >> put (csHash cs)+    get = liftM2 CompactString get get++instance Pretty CompactString where+    pretty = pretty . S.unpack . csString++instance Show CompactString where+    show = show . csString++instance Read CompactString where+    readsPrec n str = [ (fromString n, rest) | (n,rest) <- readsPrec n str]++instance Eq CompactString where+    cs1 == cs2 = if csHash cs1 == csHash cs2+                 then csString cs1 == csString cs2+                 else False++instance Ord CompactString where+    cs1 `compare` cs2+      = case csHash cs1 `compare` csHash cs2 of+          GT -> GT+          LT -> LT+          EQ -> csString cs1 `compare` csString cs2++{-# NOINLINE globalTable #-}+globalTable :: IORef (Trie.Trie CompactString)+globalTable = unsafePerformIO (newIORef Trie.empty)++append :: CompactString -> CompactString -> CompactString+append !a !b+    = fromByteString (csString a `S.append` csString b)++fromString :: String -> CompactString+fromString = fromByteString . S.pack++fromLazyByteString :: L.ByteString -> CompactString+fromLazyByteString = fromByteString . S.concat . L.toChunks++fromByteString :: S.ByteString -> CompactString+fromByteString str+    = unsafePerformIO $+      atomicModifyIORef globalTable $ \trie ->+        case Trie.lookup str trie of+          Nothing -> let cs = CompactString { csString = str+                                            , csHash   = crc32 str }+                     in (Trie.insert str cs trie, cs)+          Just cs -> (trie,cs)++qualToCompact :: (L.ByteString, L.ByteString, L.ByteString) -> CompactString+qualToCompact (pkg,mod,ident)+    | L.null pkg && L.null mod = fromLazyByteString $ zDecodeByteString ident+    | otherwise                = fromLazyByteString (L.concat [zDecodeByteString pkg+                                                              , L.pack ":"+                                                              , zDecodeByteString mod+                                                              , L.pack "."+                                                              , zDecodeByteString ident])++-- Stolen from GHC. (C) The University of Glasgow.+zDecodeByteString :: L.ByteString -> L.ByteString+zDecodeByteString = L.pack . zDecodeString . L.unpack++zDecodeString :: String -> String+zDecodeString [] = []+zDecodeString ('Z' : d : rest)+  | isDigit d = decode_tuple   d rest+  | otherwise = decode_upper   d : zDecodeString rest+zDecodeString ('z' : d : rest)+  | isDigit d = decode_num_esc d rest+  | otherwise = decode_lower   d : zDecodeString rest+zDecodeString (c   : rest) = c : zDecodeString rest++decode_upper, decode_lower :: Char -> Char++decode_upper 'L' = '('+decode_upper 'R' = ')'+decode_upper 'M' = '['+decode_upper 'N' = ']'+decode_upper 'C' = ':'+decode_upper 'Z' = 'Z'+decode_upper ch  = {-pprTrace "decode_upper" (char ch)-} ch++decode_lower 'z' = 'z'+decode_lower 'a' = '&'+decode_lower 'b' = '|'+decode_lower 'c' = '^'+decode_lower 'd' = '$'+decode_lower 'e' = '='+decode_lower 'g' = '>'+decode_lower 'h' = '#'+decode_lower 'i' = '.'+decode_lower 'l' = '<'+decode_lower 'm' = '-'+decode_lower 'n' = '!'+decode_lower 'p' = '+'+decode_lower 'q' = '\''+decode_lower 'r' = '\\'+decode_lower 's' = '/'+decode_lower 't' = '*'+decode_lower 'u' = '_'+decode_lower 'v' = '%'+decode_lower ch  = {-pprTrace "decode_lower" (char ch)-} ch++-- Characters not having a specific code are coded as z224U (in hex)+decode_num_esc :: Char -> String -> String+decode_num_esc d rest+  = go (digitToInt d) rest+  where+    go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest+    go n ('U' : rest)           = chr n : zDecodeString rest+    go n other = error ("decode_num_esc: " ++ show n ++  ' ':other)++decode_tuple :: Char -> String -> String+decode_tuple d rest+  = go (digitToInt d) rest+  where+        -- NB. recurse back to zDecodeString after decoding the tuple, because+        -- the tuple might be embedded in a longer name.+    go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest+    go 0 ('T':rest)     = "()" ++ zDecodeString rest+    go n ('T':rest)     = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest+    go 1 ('H':rest)     = "(# #)" ++ zDecodeString rest+    go n ('H':rest)     = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest+    go n other = error ("decode_tuple: " ++ show n ++ ' ':other)+
− src/DataConstructors.hs 
@@ -1,871 +0,0 @@-module DataConstructors(-    Constructor(..),-    DataTable(..),-    DataTableMonad(..),-    AliasType(..),-    DataFamily(..),-    Slot(..),-    primitiveAliases,-    dataTablePrims,-    constructionExpression,-    deconstructionExpression,-    followAliases,-    followAlias,-    tAbsurd,-    mktBox,-    modBox,-    removeNewtypes,-    getConstructor,-    getConstructorArities,-    getProduct,-    getSiblings,-    numberSiblings,-    extractPrimitive,-    boxPrimitive,-    lookupCType',-    lookupCType,-    extractIO,-    extractIO',-    pprintTypeOfCons,-    showDataTable,-    slotTypes,-    slotTypesHs,-    toDataTable,-    updateLit,-    deriveClasses,-    onlyChild,-    conSlots,-    typesCompatable-    ) where--import Control.Monad.Identity-import Control.Monad.Writer(tell,execWriter)-import Data.Monoid hiding(getProduct)-import Data.Maybe-import List(sortBy)-import qualified Data.Map as Map hiding(map)--import Data.DeriveTH-import Data.Derive.All-import C.Prims-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.Traverse-import E.TypeCheck-import E.Values-import FrontEnd.Class(instanceName)-import FrontEnd.Syn.Traverse-import FrontEnd.Tc.Type-import GenUtil-import FrontEnd.HsSyn-import Info.Types-import Name.Id-import Name.Name as Name-import Name.Names-import Name.VConsts-import PrimitiveOperators-import Support.CanType-import Support.FreeVars-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' <- 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 [70,72..]) () 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 (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2)-kind (KVar _) = error "Kind variable still existing."-kind _ = error "DataConstructors.kind"---data AliasType = NotAlias | ErasedAlias | RecursiveAlias-    deriving(Eq,Ord,Show)---- 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 !Int     -- bounded integral type, argument is maximum number-    | DataNormal [Name] -- child constructors-    deriving(Eq,Ord,Show)---- | 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-    conDeriving  :: [Name],       -- classes this type derives-    conAlias     :: AliasType,    -- whether this is a simple alias and has no tag of its own.-    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-    } deriving(Show)--data Slot =-    SlotNormal E-    | SlotUnpacked E !Name [E]-    | SlotExistential TVr-    deriving(Eq,Ord,Show)--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 {-    constructorMap :: (Map.Map Name Constructor)-    }--instance Binary DataTable where-    put (DataTable dt) = put dt-    get = fmap DataTable get--emptyConstructor = Constructor {-                conName = error "emptyConstructor.conName",-                conType = Unknown,-                conOrigSlots = [],-                conExpr = Unknown,-                conInhabits = error "emptyConstructor.conInhabits",-                conDeriving = [],-                conAlias = NotAlias,-                conVirtual = Nothing,-                conChildren = DataNone-                }--instance HasSize DataTable where-    size (DataTable d) = Map.size d--getConstructor :: Monad m => Name -> DataTable -> m Constructor-getConstructor n _ | Just e <- fromConjured modAbsurd  n = return emptyConstructor { conName = n, conType = e, conExpr = tAbsurd e, conInhabits = tStar }-getConstructor n _ | Just e <- fromConjured modBox  n = return emptyConstructor { conName = n, conType = e, conExpr = mktBox e, conInhabits = tStar }-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 = tHash,-            conChildren = DataNormal [dc]-           }--        dc = unboxedNameTuple DataConstructor n-        tc = unboxedNameTuple TypeConstructor n-        tipe = foldr ELam ftipe typeVars-        typeVars = take n [ tvr { tvrType = eStar, tvrIdent = anonymous v } | v <- [ 2,4 ..]]-        vars =  [ tvr { tvrType = EVar t, tvrIdent = anonymous v } | v <- [ 2*n + 16, 2*n + 18 ..] | 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 (anonymous 2) eStar) (ELam (tVr (anonymous 4) eStar) (EPi (tVr emptyId (EVar $ tVr (anonymous 2) eStar)) (EVar $ tVr (anonymous 4) eStar))),-            conInhabits = tStar,-            conChildren = DataAbstract-        }--primitiveConstructor name = emptyConstructor {-    conName = name,-    conType = eHash,-    conExpr = ELit (litCons { litName = name, litArgs = [], litType = eHash }),-    conInhabits = tHash,-    conChildren = DataPrimitive-    }---primitiveTable = concatMap f allCTypes  where-    f (dc,tc,rt,y,z) | z /= "void" = [typeCons,dataCons] where-        dataCons = emptyConstructor {-            conName = dc,-            conType = tipe,-            conOrigSlots = [SlotNormal rt],-            conExpr = ELam (tVr (anonymous 2) rt) (ELit (litCons { litName = dc, litArgs = [EVar (tVr (anonymous 2) rt)], litType = tipe })),-            conInhabits = tc-           }-        typeCons = emptyConstructor {-            conName = tc,-            conType = eStar,-            conExpr = tipe,-            conInhabits = tStar,-            conChildren = DataNormal [dc]-           }--        tipe = ELit (litCons { litName = tc, litArgs = [], litType = eStar })-    f _ = []----typesCompatable :: forall m . Monad m => E -> E -> m ()-typesCompatable a b = f etherialIds 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 = i, tvrType =  a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t }))-               | isEmptyId i, 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 = i, tvrType =  a}) b)-               | isEmptyId i, 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,(show c,st))-        | otherwise -> do-            Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable-            Constructor { conOrigSlots = [SlotNormal st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable-            let tvra = tVr vn st-                (vn:_) = newIds (freeIds e)-            return (eCase e  [Alt (litCons { litName = cn, litArgs = [tvra], litType = (getType e) }) (EVar tvra)] Unknown,(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,(show c,st))-        | otherwise -> do-            Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable-            Constructor { conOrigSlots = [SlotNormal st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable-            let tvra = tVr vn st-                (vn:_) = newIds (freeVars (e,et))-            if isManifestAtomic e then-                return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(show n,st))-             else-                return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(show n,st))-    e' -> fail $ "extractPrimitive: " ++ show (e,e')----- which C types these convert to in FFI specifications for--- figuring out calling conventions. not necessarily related--- to the representation.--- ideally, these could be set via a pragma--typeTable = Map.fromList [-    (tc_Char,"wchar_t"),-    (tc_Int, "int"),-    (tc_Int8, "int8_t"),-    (tc_Int16, "int16_t"),-    (tc_Int32, "int32_t"),-    (tc_Int64, "int64_t"),-    (tc_IntMax, "intmax_t"),-    (tc_IntPtr, "intptr_t"),-    (tc_Word, "unsigned"),-    (tc_Word8, "uint8_t"),-    (tc_Word16, "uint16_t"),-    (tc_Word32, "uint32_t"),-    (tc_Word64, "uint64_t"),-    (tc_WordMax, "uintmax_t"),-    (tc_WordPtr, "uintptr_t"),-    (tc_Float, "float"),-    (tc_Double, "double"),-    (tc_Addr, "HsPtr"),-    (tc_FunAddr, "HsFunPtr"),--    (tc_CChar, "char"),-    (tc_CShort, "short"),-    (tc_CInt, "int"),-    (tc_CLong, "long"),--    (tc_CSChar, "signed char"),--    (tc_CUChar, "unsigned char"),-    (tc_CUShort, "unsigned short"),-    (tc_CUInt, "unsigned int"),-    (tc_CULong, "unsigned long"),--    (tc_CWchar, "wchar_t"),-    (tc_CWint, "wint_t"),-    (tc_CTime, "time_t"),-    (tc_CSize, "size_t"),-    (tc_Unit,  "void"),-    (tc_World__,  "void")-    ]---- | Returns a string naming the C type that the given type is--- converted to/from in foreign imports/exports-lookupCType :: Monad m => E -> m String-lookupCType e = f e where-    f (ELit LitCons { litName = c })-        | Just s <- Map.lookup c typeTable = return s-    f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as)-    f e = fail $ "lookupCType: Not C Type: " ++ pprint 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"--extractIO' :: E -> (Bool,E)-extractIO' e = case extractIO e of-    Just x -> (True,x)-    Nothing -> (False,e)---- | Finds the internal constructor, E field type, and C field type--- for an FFI-able single-field, single-constructor datatype like--- 'Int' (or a newtype thereof)-lookupCType' dataTable e = case followAliases (mappend dataTablePrims dataTable) e of-    ELit LitCons { litName = c, litArgs = [] }-        | Just Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable,-          Just Constructor { conOrigSlots = [SlotNormal st@(ELit LitCons { litName = n, litArgs = [] })] } <- getConstructor cn dataTable-            -> return (cn,st,show n)-    ELit LitCons { litName = c, litArgs = [] } | Just cn  <- getConstructor c dataTable -> fail $ "lookupCType: " ++ show cn-    e' -> fail $ "lookupCType': " ++ show (e,e')---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:primitiveTable ])--deriveClasses :: IdMap Comb -> DataTable -> [(TVr,E)]-deriveClasses cmap (DataTable mp) = concatMap f (Map.elems mp) where-    f c | TypeConstructor == nameType (conName c), Just is <- conVirtual c = concatMap (g is c) (conDeriving c)-    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 2,  tvrType = typ }-        v2 = tvr { tvrIdent = anonymous 4,  tvrType = typ }-        i1 = tvr { tvrIdent = anonymous 6,  tvrType = it }-        i2 = tvr { tvrIdent = anonymous 8,  tvrType = it }-        b3 = tvr { tvrIdent = anonymous 10, tvrType = tBoolzh }-        val1 = tvr { tvrIdent = anonymous 14, 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 (func_equals sFuncNames) Op.Eq]-        h cl | cl == class_Ord = [-                mkCmpFunc (func_geq sFuncNames) Op.UGte,-                mkCmpFunc (func_leq sFuncNames) Op.ULte,-                mkCmpFunc (func_lt sFuncNames)  Op.ULt,-                mkCmpFunc (func_gt sFuncNames)  Op.UGt]-        h cl | cl == class_Enum = funcs where-            funcs = [-                (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-                ]-            iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName (func_toEnum sFuncNames) (nameName $ conName c), tvrType = getType ib_te }-            iv_fe = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName (func_fromEnum sFuncNames) (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]---            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 (APrim (Op (Op.BinOp op Op.bits16 Op.bits16) Op.bits16) mempty) [a,b] tBoolzh----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 { conAlias = ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable-        return (foldr ELam sl [ tVr (anonymous i) s | s <- getSlots cs | i <- [2,4..]])--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---{-# 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` map fst 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) | HsNewTypeDecl { hsDeclName = n, hsDeclCon = c } <- ds  ]-        fm t = execWriter $ f t-        f HsTyCon { hsTypeName = n } = tell [n]-        f t = traverseHsType_ f t-    f decl@HsNewTypeDecl {  hsDeclName = nn, hsDeclCon = c } = dt decl (if nn `elem` newtypeLoopBreakers then RecursiveAlias else ErasedAlias)  [c]-    f decl@HsDataDecl {  hsDeclCons = cs } = dt decl NotAlias  cs-    f _ = return ()-    dt decl NotAlias cs@(_:_:_) | all null (map hsConDeclArgs cs) = do-        let virtualCons'@(fc:_) = map (makeData NotAlias typeInfo) cs-            typeInfo@(theType,_,_) = makeType 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 12) rtype) (ELit (litCons { litName = consName-                                                                                   , litArgs = [EVar (tVr (anonymous 12) rtype)]-                                                                                   , litType =  conExpr theType })) }-            rtypeCons = emptyConstructor {-                conName = rtypeName,-                conType = eHash,-                conExpr = rtype,-                conInhabits = tHash,-                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-        tell (Seq.fromList dataCons)-        tell $ Seq.singleton theType { conChildren = DataNormal (map conName dataCons) }--    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,-            conAlias = 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 (map anonymous [2,4..]) ()) vs-            tipe' ty-        subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = anonymous p }) | EVar tv <- thisTypeArgs | p <- [2,4..] ]--        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 $ do-                ELit LitCons { litName = n } <- return $ followAliases fullDataTable (getType e)-                Constructor { conChildren = DataNormal [dc] } <- getConstructor n fullDataTable-                [st] <- return $ slotTypes fullDataTable dc (tvrType e)-                let nv = tvr { tvrIdent = j, tvrType = st }-                return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es-            f _ [] [] = []-            f _ _ _ = error "DataConstructors.tslots"-            fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (map anonymous [2,4 .. 2 * (length theTypeArgs + 2)])--        -- existentials are free variables in the arguments, that arn't bound in the type-        existentials = melems $ 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 = (theType,theTypeArgs,theTypeExpr) where-        theTypeName = toName Name.TypeConstructor (hsDeclName decl)-        theKind = kind $ fromJust (Map.lookup theTypeName km)-        (theTypeFKind,theTypeKArgs') = fromPi theKind-        theTypeArgs = [ tvr { tvrIdent = anonymous x } | tvr  <- theTypeKArgs' | x <- [2,4..] ]-        theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind }-        theType = emptyConstructor {-            conName = theTypeName,-            conType = theKind,-            conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,-            conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs),-            conDeriving = [ toName ClassName n | n <- hsDeclDerives decl],-            conInhabits = if theTypeFKind == eStar then tStar else tHash,-            conVirtual = Nothing,-            conChildren = undefined-            }--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 })-    | ErasedAlias <- conAlias mc = ELam var (EVar var)-    | RecursiveAlias <- conAlias 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 [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ]-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-    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 e: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 $ 2*s) t-                    as <- mapM g es-                    f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = 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 [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ]-slotTypes wdt n kind-    | sortKindLike kind, (e,ts) <- fromPi kind = drop (length ts) (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 [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ]-slotTypesHs wdt n kind-    | sortKindLike kind, (e,ts) <- fromPi kind = drop (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 $ "slotTypes: error in " ++ show n ++ ": " ++ show e--showDataTable (DataTable mp) = vcat xs where-    c  const = vcat [t,e,cs,al,vt,ih,ch] where-        t  = text "::" <+> ePretty conType-        e  = text "=" <+> ePretty conExpr-        cs = text "slots:" <+> tupled (map ePretty (conSlots const))-        al = text "alias:" <+> tshow conAlias-        vt = text "virtual:" <+> tshow conVirtual-        ih = text "inhabits:" <+> tshow conInhabits-        ch = text "children:" <+> tshow conChildren-        Constructor {-            conType = conType,-            conExpr = conExpr,-            conAlias = conAlias,-            conVirtual = conVirtual,-            conInhabits = conInhabits,-            conChildren = conChildren-            } = const-    xs = [text x <+> hang 0 (c y) | (x,y) <- ds ]-    (ubt,ubd) = tunboxedtuple 3-    ds = sortBy (\(x,_) (y,_) -> compare x y) [ (show x,y)  | (x,y) <-  Map.toList mp ++ [(conName ubt,ubt),(conName ubd,ubd)]]---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 = n, tvrType = t1 }) t2) | isEmptyId n = 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 <> text "->" <> space)-    app = bop (L,100) (text " ")---class Monad m => DataTableMonad m where-    getDataTable :: m DataTable-    getDataTable = return mempty---instance DataTableMonad Identity--primitiveAliases = [-    (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_BitsShort, rt_bits_short_),-    (tc_BitsInt, rt_bits_int_),-    (tc_BitsSize, rt_bits_size_t_),--    (tc_Float32, rt_float32),-    (tc_Float64, rt_float64),-    (tc_Float80, rt_float80),-    (tc_Float128, rt_float128)-    ]--$(derive makeBinary ''AliasType)-$(derive makeBinary ''DataFamily)-$(derive makeBinary ''Constructor)-$(derive makeBinary ''Slot)-$(derive makeMonoid ''DataTable)
− src/DataConstructors.hs-boot 
@@ -1,13 +0,0 @@-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
− src/DerivingDrift/DataP.hs 
@@ -1,34 +0,0 @@--- Adaptation and extension of a parser for data definitions given in--- appendix of G. Huttons's paper - Monadic Parser Combinators.------ Parser does not accept infix data constructors. This is a shortcoming that--- needs to be fixed.--module DerivingDrift.DataP where--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 Name = String-type Var = String-type Class = String-type Constructor = String-
− src/DerivingDrift/Drift.hs 
@@ -1,81 +0,0 @@-module DerivingDrift.Drift(driftDerive) where--import Char-import List-import Control.Monad.Identity-import qualified Data.Traversable as T--import CharIO-import DerivingDrift.DataP-import DerivingDrift.StandardRules-import FrontEnd.HsParser-import FrontEnd.ParseMonad-import FrontEnd.HsSyn-import Name.Name-import Name.Names-import Name.VConsts-import Options-import Text.PrettyPrint.HughesPJ(render)-import qualified Data.Map as Map-import qualified FlagDump as FD--driftDerive :: HsModule -> IO HsModule-driftDerive hsModule = ans where-    ans | null ss = return hsModule-        | otherwise = do-            wdump FD.Derived $ do-                CharIO.print $ hsModuleName hsModule-                mapM_ CharIO.putErrLn ss-            return hsMod'-    hsMod' = hsModule { hsModuleDecls = hsModuleDecls hsModule ++ ndcls }-    --hsMod = case parse (unlines ss) (SrcLoc (show $ hsModuleName hsModule) 1 1) 0 [] of-    hsMod = case runParser parse (unlines ss)  of-        ParseOk _ e -> e-        ParseFailed sl err -> error $ "driftDerive: " ++ show sl ++ err-    ndcls = hsModuleDecls hsMod-    ss = [ n | Just n <- map driftDerive' $ hsModuleDecls hsModule, any (not . isSpace) n ]--enumDontDerive :: [(HsName,[HsName])]-enumDontDerive = [-    (f class_Eq, [func_equals fns]),-    (f class_Ord, [func_geq fns, func_leq fns, func_lt fns, func_gt fns]),-    (f class_Enum, [func_toEnum fns,func_fromEnum fns] ++ map (nameName . toUnqualified) [v_enumFrom, v_succ, v_pred, v_enumFromThen, v_enumFromThenTo, v_enumFromTo])-    ]  where-        Identity fns = T.mapM (return . f) sFuncNames-        f n = nameName (toUnqualified n)----driftDerive' :: Monad m => HsDecl -> m String-driftDerive' HsDataDecl { hsDeclName = name, hsDeclArgs = args, hsDeclCons = condecls, hsDeclDerives = derives } = do-        let d =  toData  name args condecls derives-            isEnum = length condecls > 1 && null (concatMap hsConDeclArgs condecls)-        xs <- return $  map (derive isEnum d) derives -- (if isEnum then derives List.\\ enumDontDerive else derives )-        return $ unlines xs-driftDerive' (HsNewTypeDecl sloc cntxt name args condecl derives) = do-        let d =  toData  name args [condecl] derives-        xs <- return $ map (derive False d) derives-        return $ unlines xs--driftDerive' _ = fail "Nothing to derive"--toData :: HsName -> [HsName] -> [HsConDecl] -> [HsName] -> Data-toData name args cons derives = ans where-    f c = Body { constructor = pp (show $ hsConDeclName c), types = hsConDeclArgs c, labels = lb c }-    pp xs@(x:_) | isAlpha x = xs-    pp xs = '(':xs++")"-    lb HsConDecl {} = []-    lb r = concat [map show xs | (xs,_) <- hsConDeclRecArg r ]-    ans = D { statement = DataStmt, vars = map show args, constraints = [], name = show name,  derives = map show derives, body = map f cons }---derive True d wh | Just fns <- lookup wh enumDontDerive = inst fns where-    dummy = "{- This is a dummy instance, it will be rewritten internally -}\n"-    inst fns = dummy ++ "instance " ++ show wh ++ " " ++ name d ++ " where\n" ++ concat (intersperse "\n" (map f fns))-    f n = "    " ++ g (show n) ++ " = " ++ g (show n)-    g (c:cs) | c == '_' || c == '\'' || isAlpha c = c:cs-    g x = "(" ++ x ++ ")"--derive _ d wh | Just fn <- Map.lookup wh (Map.mapKeys (nameName . toUnqualified) standardRules) = render $ fn d-              | otherwise  = error ("derive: Tried to use non-existing rule "++show wh++" for "++name d)-
− src/DerivingDrift/RuleUtils.hs 
@@ -1,110 +0,0 @@--- utilities for writing new rules.--module DerivingDrift.RuleUtils (module Text.PrettyPrint.HughesPJ,module DerivingDrift.RuleUtils, module DerivingDrift.DataP)where--import Text.PrettyPrint.HughesPJ-import DerivingDrift.DataP---- Rule Declarations--x = text "x"-f = text "f"--rArrow = text "->"-lArrow = text "<-"---equals = text "="-blank = text "_"-semicolon = char ';'------ New Pretty Printers -----------------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 (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 
@@ -1,224 +0,0 @@-module DerivingDrift.StandardRules (standardRules) where--import DerivingDrift.RuleUtils-import List-import Name.Prim-import Name.Name-import qualified Data.Map as Map------ Add Rules Below Here ------------------------------------------------------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)]------------------------------------------------------------------------------------- Rules for the derivable Prelude Classes---- Eq--eqfn = instanceSkeleton "Eq" [(makeEq,defaultEq)]--makeEq :: IFunction-makeEq (Body{constructor=constructor,types=types})-	| null types = hsep $ texts [constructor,"==",constructor, "=", "True"]-	| otherwise = let-	v = varNames types-	v' = varNames' types-	d x = parens . hsep $ text constructor : x-	head = [ text "==", d v', text "="]-	body = sepWith (text "&&") $-		zipWith (\x y -> (x <+> text "==" <+> y)) v v'-	in d v <+> fsep (head ++  body)--defaultEq = hsep $ texts ["_", "==", "_", "=" ,"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 "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 "compare",x,y]-		      list [x] [y] = one x y-		      list xs ys = fsep [text "foldl", parens fn, text "EQ",-			           bracketList (zipWith one xs ys)]-		      fn = fsep $ texts  ["\\x y", "->", "if", "x", "==","EQ",-			   "then", "compare", "y", "EQ", "else", "x"]-		in if constructor b == constructor b' then-		    text "compare" <+> fsep [head,-			     list (varNames $ types b) (varNames' $ types b')]-		   else  text "compare" <+> fsep [head,text (cmp n n')]-    in simpleInstance "Ord" d <+> text "where" $$ block ifn----------------------------------------------------------------------------- Show & Read--- 	won't work for infix constructors--- 	(and anyway, neither does the parser currently)------ Show--showfn = instanceSkeleton "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 "showsPrec"-	headfn = fsep [char 'd',(pattern constructor types),equals]-	bodyStart = fsep [text "showParen",parens (text "d >= 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 "showsPrec", text "10", x]) (varNames types)-	b' = zipWith (\x l -> fsep[showString l,comp,showChar '=',comp,x])-			            b labels-	s = fsep [comp,showChar ' ', comp]-	s' = fsep [comp,showChar ',',comp]-	showChar c = fsep [text "showChar", text ('\'':c:"\'")]-	showString s = fsep[ text "showString", doubleQuotes $ text s]-	comp = char '.'---- Read--readfn d = simpleInstance "Read" d <+> text "where" $$ readsPrecFn d--readsPrecFn d = let-	fnName = text "readsPrec"-	bodies = vcat $ sepWith (text "++") (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 "readParen", parens (text "d > 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 (text $ show 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 "lex",ip]-	readsPrec = fsep [text "readsPrec",text "10"]-	from = text "<-"---------------------------------------------------------------------------- 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 (name d)-	   else simpleInstance "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},n) = text "fromEnum" <+> (fsep $-		texts [constructor , "=", show n])--toEnumFn :: Data -> [Doc]-toEnumFn (D{body=body}) = map f (zip body [0 :: Int ..])-	where-	f (Body{constructor=constructor},n) = text "toEnum" <+> (fsep $-		texts [show n , "=", constructor])--enumFromFn :: Data -> Doc-enumFromFn D{body=body} = let-	conList = bracketList . texts . map constructor $ body-	bodydoc = fsep [char 'e', char '=', text "drop",-		parens (text "fromEnum" <+> char 'e'), conList]-	in text "enumFrom" <+> bodydoc--enumFromThenFn ::  Doc-enumFromThenFn = let-	wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(",-		 "enumFrom", "i", ")"]-	eq1 = text "enumFromThen\'" <+> fsep (texts ["_","_","[]","=","[]"])-	eq2 = text "enumFromThen\'" <+> fsep ( texts ["i","j","(x:xs)","=",-		"let","d","=","fromEnum","j","-","fromEnum","i","in",-		"x",":","enumFromThen\'","i","j","(","drop","(d-1)","xs",")"])-	in text "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 name--boundedEnum d@D{body=body} = let f = constructor . head $ body-			         l = constructor . last $ body-	in simpleInstance "Bounded" d <+> text "where" $$ block [-		hsep (texts[ "minBound","=",f]),-		hsep (texts[ "maxBound","=",l])]--boundedSingle d@D{body=body} = let f = head $ body-	in simpleInstance "Bounded" d <+> text "where" $$ block [-		hsep . texts $ [ "minBound","=",constructor f] ++-			replicate (length (types f)) "minBound",-		hsep . texts $ [ "maxBound","=",constructor f] ++-			replicate (length (types f)) "maxBound"]--singleton [x] = True-singleton _ = False-
− src/Doc/Attr.hs 
@@ -1,41 +0,0 @@-module Doc.Attr(Attr(..), attrEmpty, ansi, html)  where--import Text.PrettyPrint.ANSI.Leijen---- FIXME: Use a datatype for the color.-data Attr = Attr { attrBold :: Doc -> Doc-                 , attrColor :: String -> Doc -> Doc-                 }--attrEmpty = Attr { attrBold = id, attrColor = \_ -> id }---ansi,html :: Attr--ansi = attrEmpty {-    attrBold = \x -> bold x,-    attrColor = \c x -> ansiColor c x-        }--html = attrEmpty {-    attrBold = \x -> text "<b style=\"color: white\">" <> x <> text "</b>",-    attrColor = \c x -> text ("<span style=\"color: " ++ c ++ ";\">") <> x <> text "</span>"-        }---ansiColor "black"       = dullblack -- "0;30"-ansiColor "red"         = dullred -- "0;31"-ansiColor "green"       = dullgreen -- "0;32"-ansiColor "yellow"      = dullyellow -- "0;33"-ansiColor "blue"        = dullblue -- "0;94"-ansiColor "magenta"     = dullmagenta -- "0;35"-ansiColor "cyan"        = dullcyan -- "0;36"-ansiColor "white"       = dullwhite -- "0;37"-ansiColor "lightgreen"  = green -- "0;92"-ansiColor "lightred"    = red -- "0;91"-ansiColor "brightblue"  = blue -- "0;94"-ansiColor _ = id -- "0"--attrClear = "\27[0m"--
− src/Doc/Chars.hs 
@@ -1,71 +0,0 @@--- | A variety of useful constant documents representing many unicode characters.--module Doc.Chars where--import 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 
@@ -1,184 +0,0 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances #-}-module Doc.DocLike where---- arch-tag: a88f19fb-e18d-475f-b6d1-8da78676261a--import Data.Monoid-import Control.Monad.Reader()-import List-import qualified Text.PrettyPrint.ANSI.Leijen 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 = enclose l r . hcat . punctuate s-    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 = text . show----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--instance Monoid P.Doc where-    mappend = (P.<>)-    mempty = P.empty-    mconcat = P.hcat--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 
@@ -1,66 +0,0 @@---- | 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---class DocLike d => PPrint d a  where-    pprint ::  a -> d-    pprintPrec :: Int -> a -> d--    pprintPrec _ a = pprint a-    pprint a = pprintPrec 0 a---    pplist    ::  [a] -> d-    pplist    xs = brackets (hcat (punctuate comma (map pprint xs)))--pprintParen :: PPrint d a => a -> d-pprintParen = pprintPrec 11--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])--instance (PPrint d a, PPrint d b) => PPrint d (Either a b) where-  pprintPrec n (Left x)  | n <= 9  = text "Left" <+> pprintPrec 10 x-  pprintPrec n (Right x) | n <= 9  = text "Right" <+> pprintPrec 10 x-  pprintPrec _ x = parens (pprint 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 
@@ -1,80 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--------------------------------------------------------------- Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan--------- 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--------------------------------------------------------------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-        ) where--import Doc.DocLike hiding(empty)-import qualified Doc.DocLike as DocLike--import Text.PrettyPrint.ANSI.Leijen hiding (hsep, hcat)-import System.Console.ANSI---errorDoc :: Doc -> a-errorDoc = error . ('\n':) . show--failDoc :: Monad m => Doc -> m a-failDoc = fail . ('\n':) . show--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}-      display (SSGR sgr x)  = do putStr (setSGRCode sgr); display x--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"----------------------------------------------------------------- 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-
− src/E/Annotate.hs 
@@ -1,169 +0,0 @@-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.Rules-import E.Subst-import GenUtil-import Name.Id-import qualified Info.Info as Info-import Info.Info(Info)-import Util.SetLike-import Util.HasSize--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--{-- This function seems to do two distinct tasks:-  1) variable substitution.-  2) annotate TVrs in lambdas and lets.- Why can't we do this in two separate passes?-- Invariants:-   'imap' may only contain top-level decls.--}-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 | isEmptyId n  = 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 = i, tvrType =  t}) | isEmptyId i = 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 `mmember` ss  = newId (size ss) isOkay-    | otherwise = i-    where isOkay i = (i `mnotMember` ss) && (i `notElem` xs)--
− src/E/Arbitrary.hs 
@@ -1,158 +0,0 @@-module E.Arbitrary where----import Test.QuickCheck-import E.E-import E.TypeCheck()-import qualified Data.Set as Set-import qualified Data.Map as Map-import Random-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty (putDoc, Doc)-import E.Show-import Data.Monoid-import GenUtil-import Support.FreeVars-import Name.VConsts-import Support.CanType-import CharIO----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 (2*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-    CharIO.print e-    CharIO.putStrLn (render $ (ePretty e :: Doc))-    putDoc (pprint (getType e))--testE = do-    CharIO.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 
@@ -1,262 +0,0 @@-module E.Binary() where--import StringTable.Atom-import Data.Binary-import E.Type-import Monad-import {-# SOURCE #-} Info.Binary(putInfo,getInfo)---- Binary instance-data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int--instance Binary TVr where-    put (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf} ) = do-        put i-        put e-        putInfo nf-    get  = do-        i <- get-        e <- get-        nf <- getInfo-        return $ TVr i e nf--instance Binary TvrBinary where-    put TvrBinaryNone = do putWord8  0-    put (TvrBinaryAtom aa) = do-        putWord8 1-        put aa-    put (TvrBinaryInt ab) = do-	    putWord8 2-	    put ab-    get = do-	    h <- getWord8-	    case h of-	      0 -> do return TvrBinaryNone-	      1 -> do-		    aa <- get-		    return (TvrBinaryAtom aa)-	      2 -> do-		    ab <- get-		    return (TvrBinaryInt ab)-	      _ -> fail "invalid binary data found"--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/CPR.hs 
@@ -1,139 +0,0 @@-module E.CPR(Val(..), cprAnalyzeDs, cprAnalyzeProgram) where--import Control.Monad.Writer hiding(Product(..))-import Data.Binary-import Data.Typeable-import Data.Monoid()-import qualified Data.Map as Map--import Data.DeriveTH-import Data.Derive.All-import DataConstructors-import Doc.DocLike-import E.E-import E.FreeVars-import GenUtil-import E.Program-import Name.Name-import Name.Names-import Cmm.Number-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 makeBinary ''Val)--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 xs) = shows n <> tupled (map shows xs)-    showsPrec _ (VInt 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 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 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----
− src/E/Demand.hs 
@@ -1,423 +0,0 @@-module E.Demand(-    Demand(..),-    DemandSignature(..),-    DemandType(..),-    SubDemand(..),-    analyzeProgram,-    absSig,-    solveDs,-    lazy-    ) where---import Control.Monad.Reader-import Control.Monad.Writer hiding(Product(..))-import Data.Binary-import Data.List-import Data.Monoid hiding(Product(..))-import Data.Maybe-import Data.Typeable--import Data.DeriveTH-import Data.Derive.All-import DataConstructors-import Doc.DocLike-import Doc.PPrint-import E.E-import E.Program-import GenUtil-import Info.Types-import Name.Id-import qualified Info.Info as Info-import Util.HasSize-import Util.SetLike--data Demand =-    Bottom             -- always diverges-    | L SubDemand      -- lazy-    | S SubDemand      -- strict-    | Error SubDemand  -- diverges, might use arguments-    | Absent           -- Not used-    deriving(Eq,Ord,Typeable)--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--data SubDemand = None | Product [Demand]-    deriving(Eq,Ord,Typeable)--data DemandSignature = DemandSignature !Int DemandType-    deriving(Eq,Ord,Typeable)--data DemandType = (:=>) DemandEnv [Demand]-    deriving(Eq,Ord,Typeable)--data DemandEnv = DemandEnv (IdMap Demand) Demand-    deriving(Eq,Ord,Typeable)--instance Binary DemandEnv where-    put (DemandEnv dt d) = do-        put dt-        put d-    get = do-        m <- get-        d <- get-        return $ DemandEnv m d---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 ">"--idGlb = Absent--absType = (DemandEnv mempty idGlb) :=> []-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') :=> zipWith lub (ts ++ repeat lazy) ts'-                                    | otherwise = (env `lub` env') :=> zipWith lub ts (ts' ++ repeat lazy)-    glb (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `glb` env') :=> zipWith glb (ts ++ repeat lazy) ts'-                                    | otherwise = (env `glb` env') :=> zipWith glb ts (ts' ++ repeat lazy)--lazy = L None-strict = S None-err = Error None--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 (mdelete (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 <- mkeys m1 ++ mkeys 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 <- mkeys m1 ++ mkeys 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))-extEnvs ts = local  (\ (env,dt) -> (mappend (fromList [ (tvrIdent t,Left s) |  (t,s) <- ts, not (isEmptyId (tvrIdent t))]) env,dt))---instance DataTableMonad IM where-    getDataTable = asks snd--runIM :: IM a -> DataTable -> a-runIM (IM im) dt = 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 = i } e) (S (Product [s])) | isEmptyId i= 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)] id (\nn -> f rs (nn ++ fs))-    f (Right rg:rs) fs = do-        solveDs' (Just True) rg id (\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 (mdelete (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)---{-# NOINLINE solveDs #-}-solveDs dataTable ds =-    runIM (solveDs' Nothing ds fixupDemandSignature return) dataTable---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' (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' 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 True) ds fixup wdone = do-    let ds' = [ ((t,e),sig) | (t,e) <- ds, let sig = maybe absSig id (Info.lookup (tvrInfo t))]-        g False [] ds = wdone [ (tvrInfo_u (Info.insert (fixup sig)) t,e) | ((t,e),sig) <- ds ]-        g True [] ds = extEnvs [ (t,sig)| ((t,_),sig) <- ds] $ g False ds []-        g ch (((t,e),sig):rs) fs = do-            (ne,sig') <- topAnalyze t e-            let sig'' = sig `extendSig` sig'-            g (ch || (sig'' /= sig)) rs (((t,ne),sig''):fs)-    g True [] ds'--{-# NOINLINE analyzeProgram #-}-analyzeProgram prog =-    let dsOut = solveDs (progDataTable prog) (programDs prog)-    in programSetDs' dsOut prog--$(derive makeBinary ''Demand)-$(derive makeBinary ''SubDemand)-$(derive makeBinary ''DemandSignature)-$(derive makeBinary ''DemandType)
− src/E/Diff.hs 
@@ -1,48 +0,0 @@---- | Attempt to find pretty printable differences between terms.---module E.Diff where--import E.E-import E.Traverse-import E.FreeVars()-import Support.FreeVars-import Stats---- | 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 
@@ -1,167 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-module E.E(-    Id(),-    IdMap(),-    IdSet(),-    newIds,-    module E.Type,-    module E.E,-    module E.FreeVars-    ) where--import Char(chr)-import qualified Data.Traversable as T-import List-import Maybe--import E.FreeVars-import C.Prims-import Control.Monad.Identity-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-    tStar = eStar-    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 = tWorld__, litArgs = [], litType = eHash })-    tIntzh = ELit (litCons { litName = tIntzh, litArgs = [], litType = eHash })-    tEnumzh = ELit (litCons { litName = tEnumzh, litArgs = [], litType = eHash })-    tIntegerzh = ELit (litCons { litName = tIntegerzh, litArgs = [], litType = eHash })-    tCharzh = ELit (litCons { litName = tCharzh, 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 (LitInt 1 tEnumzh)], litType = tBool })-    vFalse = (litCons { litName = dc_Boolzh, litArgs = [ELit (LitInt 0 tEnumzh)], litType = tBool })-    vUnit  = (litCons { litName = vUnit, litArgs = [], litType = tUnit })----tFunc a b = ePi (tVr emptyId a) b---- values----tvrSilly = tVr sillyId Unknown---------------------- 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 = maybe ('x':(show $ tvrIdent t)) show (tvrName t)---modAbsurd = "Lhc@.Absurd"-modBox    = "Lhc@.Box"---nameConjured :: String -> E -> Name-nameConjured mod n = toName TypeConstructor (mod,f n "") where-    f (ESort s) = shows s-    f (EPi TVr { tvrType = t1 } t2) = ('^':) . shows t1 . shows t2-    f _ = error $ "nameConjured: " ++ show (mod,n)--fromConjured :: Monad m => String -> 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"--eToList :: Monad m => E -> m  [E]-eToList (ELit LitCons { litName = n, litArgs = [e,b] }) | vCons == n = eToList b >>= \x -> return (e:x)-eToList (ELit LitCons { litName = n, litArgs = [] }) | vEmptyList == n = return []-eToList _ = fail "eToList: not list"--toString (ELit LitCons { litName = n, litArgs = [], litType = t }) = if vEmptyList == 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 && t == tCharzh = 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)-
− src/E/Eta.hs 
@@ -1,226 +0,0 @@-module E.Eta(-    ArityType(ATop,ABottom),-    etaExpandAp,-    annotateArity,-    deleteArity,-    etaExpandDef,-    etaExpandDef',-    etaExpandProgram,-    getArityInfo,-    etaAnnotateProgram,-    etaReduce-    ) where--import Control.Monad.Identity-import Control.Monad.Writer-import Control.Monad.State-import Data.Monoid-import Data.Typeable-import Maybe--import DataConstructors-import E.Annotate-import E.E-import E.Inline-import E.Program-import E.Subst-import E.Values-import GenUtil hiding(replicateM_)-import Info.Types-import Name.Id-import Support.CanType-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)--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--lamann _ nfo = return nfo--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 (rec,ts) = do-        let (ts',fs) = runState (annotateCombs mempty pass letann pass ts) False-        if fs then f (rec,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 isEmptyId (tvrIdent t)-         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 isEmptyId (tvrIdent t)-         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 
@@ -1,122 +0,0 @@-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 Control.Monad.Writer-import qualified Data.Map as Map--import Doc.DocLike-import Doc.PPrint-import E.E-import E.FreeVars-import {-# SOURCE #-} E.Show-import E.Subst-import Name.Id (isEmptyId)-import Name.Names (tc_Arrow)--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 LitCons { litName = n, litArgs = [a, b] }) [] | n == tc_Arrow = tFunc (eval a) (eval b)-    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----{- Lemmih 08.11.26:-'dsMap' is the current scope with known bindings.-Inline all lets and perform beta reduction.-Invariants:-  All variables must be unique. No shadowing is allowed.-  All variables must be named.--}-strong :: Monad m => [(TVr,E)] -> E -> m E-strong dsMap' term = eval' dsMap term [] where-    dsMap = Map.fromList dsMap'-    --eval' ds t@EVar {} [] = t-    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 LitCons { litName = n, litArgs = [a,b] }) [] | n == tc_Arrow = do-        a' <- eval' ds a []-        b' <- eval' ds b []-        return (tFunc a' b')-    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 = i }) _stack | isEmptyId i = fail "empty ident in term"-    eval' ds t@(EVar v) stack-        | Just x <- Map.lookup v ds = 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 (Map.keys 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 
@@ -1,141 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-module E.FreeVars(-    decomposeLet,-    decomposeDs,-    caseUpdate,-    freeIds-    ) where--import Data.Monoid--import E.Type-import GenUtil-import Name.Id-import Support.FreeVars-import Util.SetLike as S-import Util.Graph------------------------------ finding free variables----------------------------getLitTyp (LitInt _ t) = t-getLitTyp LitCons { litType = t } = t--instance FreeVars E [TVr] where-    freeVars x = melems $ (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) = mdelete i $ fv e <> fv t-    fv (EPi  TVr { tvrIdent = i, tvrType = t} e) = mdelete 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:(mdelete (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 
@@ -1,1007 +0,0 @@-module E.FromHs(-    convertDecls,-    convertRules,-    createInstanceRules,-    procAllSpecs,-    getMainFunction-    ) where--import Char-import Control.Monad.Identity-import Control.Monad.RWS-import qualified Data.Traversable as T-import Data.Monoid-import List(isPrefixOf)-import Maybe-import Prelude-import qualified Data.Map as Map-import qualified Text.PrettyPrint.ANSI.Leijen as PPrint--import C.FFI-import C.Prims as CP-import StringTable.Atom-import DataConstructors-import Doc.DocLike-import Doc.PPrint-import E.E-import E.Eta-import E.Eval(eval)-import E.LetFloat(atomizeAp)-import E.PrimOpt-import E.Rules-import E.Show(render)-import E.Subst-import E.Traverse-import E.TypeCheck-import E.Values-import FrontEnd.Class-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 FrontEnd.HsSyn as HS-import Info.Types-import Name.Name as Name-import Name.Names-import Name.Id-import Name.VConsts-import Options-import PackedString-import PrimitiveOperators-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---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 :: Monad m => [E] -> Ce m [TVr]-newVars xs = f xs [] where-    f [] xs = return $ reverse xs-    f (x:xs) ys = do-        s <- newUniq-        f xs (tVr (anonymous (2*s)) x:ys)---tipe t = f t where-    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' <- 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 }-    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"---simplifyDecl (HsPatBind sl (HsPVar n)  rhs wh) = HsFunBind [HsMatch sl n [] rhs wh]-simplifyDecl x = x----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"--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 = anonymous 2, 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)---{-# NOINLINE createInstanceRules #-}-createInstanceRules :: DataTable -> ClassHierarchy -> [(TVr,E)] -> Rules-createInstanceRules dataTable classHierarchy funcs = fromRules ans where-    ans = concatMap cClass (classRecords classHierarchy)-    cClass classRecord =  concat [ method classRecord n | (n,TForAll _ (_ :=> t)) <- classAssumps classRecord ]-    method classRecord methodName | isJust _methodName = as where-        methodVar = tVr (toId methodName) ty-        _methodName@(~(Just (TVr {tvrType = ty},_))) = findName methodName-        defaultName =  (defaultInstanceName methodName)-        valToPat' (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts') where-            ts' = [ EVar (tVr (anonymous j) (getType z)) | z <- ts | j <- [2,4 ..], anonymous j `notElem` map tvrIdent args]-        --valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ litCons { litName = tc_Arrow, litArgs = [ EVar (tVr j (getType z)) | z <- [a,b] | j <- [2,4 ..], j `notElem` map tvrIdent args], litType = eStar }-        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:_) = [ anonymous j |  j <- [2,4 ..], anonymous j `notElem` map tvrIdent args]-        valToPat' x = error $ "FromHs.valToPat': " ++ show x-        as = [ rule  t | Inst { instHead = _ :=> IsIn _ t }  <- snub (classInsts classRecord) ]-        (_ft,_:args') = fromPi ty-        (args,_rargs) = span (sortKindLike . getType)  args'-        rule t = makeRule ("Rule.{" ++ show name ++ "}") (Module (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))-            --vp@(ELit LitCons { litArgs =  vs }) = tpat-            body = case findName name of-                Just (n,_) -> foldl EAp (EVar n) (vs ++ map EVar args)-                Nothing -> case findName defaultName of-                    Just (deftvr,_) | null vs -> foldl EAp (EAp (EVar deftvr) vp) (map EVar args)-                    Just (deftvr,_) -> eLet tv vp $ foldl EAp (EAp (EVar deftvr) (EVar tv)) (map EVar args) where-                        tv = tvr { tvrIdent = head [ n | n <- newIds (freeVars vp)], tvrType = getType vp }-                    Nothing -> foldl EAp (EError ( show methodName ++ ": undefined at type " ++  show (pprint t :: PPrint.Doc)) (eAp ty (fst $ valToPat' (tipe t)))) (map EVar args)-    method _ _ = []-    nfuncs = runIdentity $ do-        let f d@(v,_) = case fromId (tvrIdent v) of-                Just n -> return (n,d)-                Nothing -> fail $ "createInstanceRules: top level var with temporary name " ++ show v-        xs <- mapM f funcs-        return (Map.fromList xs)--    findName name = case Map.lookup name nfuncs 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 (cna,sta,ta) = lookupCType' dataTable te--createFunc :: Monad m => DataTable -> [E] -> ([(TVr,String)] -> (E -> E,E)) -> Ce m E-createFunc dataTable es ee = do-    xs <- flip mapM es $ \te -> do-        res@(_,sta,rt) <- lookupCType' dataTable te-        [n,n'] <- newVars [te,sta]-        return (n,(n',rt),res)-    let tvrs' = [ n' | (_,n',_) <- xs ]-        tvrs = [ t | (t,_,_) <- xs]-        (me,innerE) = ee tvrs'-        eee = me $ foldr esr innerE xs-        esr (tvr,(tvr',_),(cn,_,_)) e = eCase (EVar tvr) [Alt (litCons { litName = cn, litArgs = [tvr'], litType = te }) e] Unknown  where-            te = getType $ EVar tvr-    return $ foldr ELam eee tvrs--instance GenName String where-   genNames i = map (('x':) . show) [i..]--{-# NOINLINE convertRules #-}-convertRules :: Monad m => Module -> TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> m Rules-convertRules mod tiData classHierarchy assumps dataTable hsDecls = ans where-    ans = do-        rawRules <- concatMapM g hsDecls-        return $ fromRules [ makeRule n (mod,i) ruleType vs head args e2-                             | (catalyst,method,n,vs,e1,e2) <- rawRules,-                               let (EVar head,args) = fromAp e1,-                               let ruleType | catalyst  = RuleCatalyst-                                            | method    = RuleSpecialization-                                            | otherwise = RuleUser-                             | 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 $ nameName (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,hsRuleIsMethod pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)--convertE :: Monad m => TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> SrcLoc -> HsExp -> m E-convertE tiData classHierarchy assumps dataTable srcLoc exp = do-    [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable [HsPatBind srcLoc (HsPVar sillyName') (HsUnGuardedRhs exp) []]-    return e--v_silly = toName Val ("Lhc@","silly")-sillyName' = nameName v_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 Ce t a = Ce (RWST CeEnv [Warning] Int t a)-    deriving(Monad,Functor,MonadTrans,MonadIO,MonadReader CeEnv,MonadState Int)--instance Monad t => MonadWarn (Ce t) where-    addWarning w = Ce $ tell [w]--instance Monad t => MonadSrcLoc (Ce t) where-    getSrcLoc = asks ceSrcLoc--instance Monad t => MonadSetSrcLoc (Ce t) where-    withSrcLoc sl = local (\ce -> ce { ceSrcLoc = sl })--instance Monad m => UniqueProducer (Ce m) where-    newUniq = do-        i <- get-        put $! (i + 1)-        return i--instance Monad m => DataTableMonad (Ce m) where-    getDataTable = asks ceDataTable--applyCoersion :: Monad m => CoerceTerm -> E -> Ce m 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)---- | return primitive instances associated with class given as argument-primitiveInstances :: Name -> [(Name,TVr,E)]-primitiveInstances name = [(n,setProperties [prop_INSTANCE,prop_INLINE] $ tVr (toId n) (getType v),v) | (cn,n,v) <- constantMethods, cn == name]--{-# NOINLINE convertDecls #-}-convertDecls :: Monad m => TiData -> IdMap Properties -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> m [(Name,TVr,E)]-convertDecls tiData props classHierarchy assumps dataTable hsDecls = liftM fst $ evalRWST ans ceEnv 2 where-    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)--    marshallToC :: Monad m => DataTable -> E -> E -> Ce m E-    marshallToC dataTable e te | otherwise = do-        (cna,sta,ta) <- lookupCType' dataTable te-        [tvra] <- newVars [sta]-        return $ eCase e-                       [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })-                            (EVar tvra)]-                       Unknown--    marshallFromC :: Monad m => DataTable -> E -> E -> Ce m E-    marshallFromC dataTable ce te | otherwise = do-        (cna,sta,ta) <- lookupCType' dataTable te-        return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })--    -- first argument builds the actual call primitive, given -    -- (a) the C argtypes-    -- (b) the C return type-    -- (c) whether it's IO-like or not-    -- (d) the real return type-    -- (e) the arguments themselves-    -- ccallHelper returns a function expression to perform the call, when given the arguments-    ccallHelper :: Monad m => ([ExtType] -> ExtType -> Bool -> [E] -> E -> E) -> E -> Ce m E-    ccallHelper myPrim ty = do-        let (ts,rt) = argTypes' ty-            (isIO,rt') =  extractIO' rt-        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]-        pt <- lookupCType rt'-        cts <- mapM lookupCType (filter (not . sortKindLike) ts)-        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]-        let cFun = createFunc dataTable (map tvrType es)-            prim = myPrim cts pt-        case (isIO,pt) of-            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $-                        eStrictLet tvrWorld2 -                                   (prim True-                                         (EVar tvrWorld-                                          :[EVar t | (t,_) <- rs ])-                                         tWorld__)-                                   (eJustIO (EVar tvrWorld2) vUnit)-            (False,"void") -> fail "pure foreign function must return a valid value"-            _ -> do-                (cn,rtt',_) <- lookupCType' dataTable rt'-                [rtVar,rtVar'] <- newVars [rt',rtt']-                let rttIO = ltTuple [tWorld__, rt']-                    rttIO' = ltTuple' [tWorld__, rtt']-                case isIO of-                    False -> cFun $ \rs -> (,) id $-                                 eStrictLet rtVar'-                                           (prim False-                                                 [ EVar t | (t,_) <- rs ]-                                                 rtt')-                                           (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })-                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $-                                eCaseTup' (prim True-                                                (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)))--    cDecl :: Monad m => HsDecl -> Ce m [(Name,TVr,E)]-    cDecl (HsForeignDecl _ (FfiSpec (Import cn req) _ Primitive) n _) = do-        let name      = toName Name.Val n-        (var,ty,lamt) <- convertValue name-        let (ts,rt)   = argTypes' ty-            prim      = APrim (PrimPrim $ toAtom cn) req-        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]-        let result    = foldr ($) (processPrimPrim dataTable $ EPrim prim (map EVar es) rt) (map ELam es)-        return [(name,setProperty prop_INLINE var,lamt result)]-    cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do-        let name       = toName Name.Val n-        (var,ty,lamt) <- convertValue name-        let (ts,rt)    = argTypes' ty-        (cn,st,_ct) <- lookupCType' dataTable rt-        [uvar] <- newVars [st]-        let expr x     = return [(name,setProperty prop_INLINE var,lamt x)]-            prim       = APrim (AddrOf $ packString rcn) req-        expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt }))--    cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) _ CCall) n _) = do-        let name = toName Name.Val n-        (var,ty,lamt) <- convertValue name-        result <- ccallHelper-                     (\cts crt io args rt ->-                      EPrim (APrim (Func io (packString rcn) cts crt) req) 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 io args rt ->-                      EPrim (APrim (IFunc io (tail cts) crt) (Requires [] [])) 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,rt) = argTypes' ty-            (isIO,rt') = extractIO' rt-        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]-        pt <- lookupCType rt'-        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]-        dnet <- parseDotNetFFI rcn-        let cFun = createFunc dataTable (map tvrType es)-            prim rs rtt = EPrim (APrim dnet { primIOLike = isIO } mempty)-        result <- case (isIO,pt) of-            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $-                        eStrictLet tvrWorld2 (prim rs "void" (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)-            (False,"void") -> fail "pure foreign function must return a valid value"-            _ -> do-                (cn,rtt',rtt) <- lookupCType' dataTable rt'-                [rtVar,rtVar'] <- newVars [rt',rtt']-                let rttIO = ltTuple [tWorld__, rt']-                    rttIO' = ltTuple' [tWorld__, rtt']-                case isIO of-                    False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | (t,_) <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })-                    True -> cFun $ \rs -> (,) (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 {} = fail ("Unsupported foreign declaration: "++ show x)--    cDecl (HsForeignExport _ ffi@(FfiExport ecn _ cc@CCall) 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'--        retCTy <- if retTy == tUnit-                  then return unboxedTyUnit-                  else liftM (\(_, _, x) -> rawType x) $ lookupCType' dataTable retTy-                          -        argCTys <- liftM (map rawType) (mapM (liftM (\(_,_,x) -> x) . lookupCType' dataTable) argTys)--        argTvrs <- newVars argCTys-        argEs <- sequence [(marshallFromC dataTable (EVar v) et) | v <- argTvrs | et <- argTys]-        -        fe <- actuallySpecializeE (EVar tn) ty-        let inner = foldl EAp fe argEs--        retE <- case isIO of-                  False -> marshallToC dataTable inner retTy-                  True -> do [world_, world__, ret] <- newVars [tWorld__, tWorld__, retTy]-                             retMarshall <- if retTy == tUnit-                                            then return (ELit (unboxedTuple []))-                                            else marshallToC dataTable (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 lookupCType (retTy:argTys)--        return [(name,-                 tvrInfo_u (Info.insert (ffi, (realArgCTys,realRetCTy)))-                           (fmap (const (foldr tFunc retCTy' argCTys)) $-                            --fmap (const Unknown) $-                              setProperty prop_EXPORTED fn),-                 result)]--    cDecl x@HsForeignExport {} = fail ("Unsupported foreign export: "++ show x)--    cDecl (HsPatBind sl (HsPVar n) (HsUnGuardedRhs exp) []) | n == sillyName' = 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 HsNewTypeDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCon = dcon, hsDeclDerives = derives } = return $ makeDerives dname dargs [dcon] (map (toName ClassName) derives)-    cDecl HsDataDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCons = dcons, hsDeclDerives = derives } = return $ makeDerives dname dargs dcons (map (toName ClassName) derives)-    cDecl cd@(HsClassDecl {}) = cClassDecl cd-    cDecl _ = return []-    makeDerives dname dargs dcons derives  = concatMap f derives where-        f n | n == class_Bounded, all (null . hsConDeclArgs) dcons  = []-        f _ = []-    cExpr :: Monad m => HsExp -> Ce m 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 (APrim (PrimString (packString s)) mempty) [] (rawType "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 (HsInt i))) = ans where-        t' = getAssump n'-        ty = tipe t'-        ans = case lookupCType' dataTable ty of-            Just (cn,st,_it) -> return $ ELit (litCons { litName = cn, litArgs = [ELit (LitInt (fromIntegral i) st)], litType = ty })-            Nothing -> 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 (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 = fail ("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 :: Monad m => [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> Ce m 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 _ (HsQualType _ (HsTyApp (HsTyCon name) _)) decls) = do-        props <- asks ceProps-        let ds = map simplifyDecl decls-            cr = findClassRecord classHierarchy className-            className = (toName ClassName name)-            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) -- ++ primitiveInstances className)-    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) (rawType "bits<max>")], litType = tInteger })-intConvert i =  ELit (litCons { litName = dc_Int, litArgs = [ELit $ LitInt (fromInteger i) (rawType "bits32")], litType = tInt })--intConvert' funcs typ i = EAp (EAp fun typ) (ELit (litCons { litName = con, litArgs = [ELit $ LitInt (fromInteger i) (rawType rawtyp)], litType = ltype }))  where-    (con,ltype,fun,rawtyp) = case abs i > integer_cutoff of-        True -> (dc_Integer,tInteger,f_fromInteger,"bits<max>")-        False -> (dc_Int,tInt,f_fromInt,"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--patVar ::-    Monad m-    => HsPat -- ^ the pattern-    -> E     -- ^ the type of the expression-    -> Ce m (HsPat,TVr)  -- ^ a new pattern and a binding variable-patVar HsPWildCard t = return (HsPWildCard,tvr { tvrType = t })-patVar (HsPVar n) t | isTypePlaceholder n = return (HsPWildCard,tvr { tvrType = t })-patVar (HsPAsPat n p) t | not (isTypePlaceholder n) = do-    nn <- convertVar (toName Name.Val n)-    return (p,nn)-patVar (HsPAsPat n p) t | isTypePlaceholder n = patVar p t-patVar p t = do-    [nv] <- newVars [t]-    return (p,nv)---tidyPat ::-    Monad m-    => HsPat-    -> E-    -> Ce m (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 conAlias patCons of-            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)---- 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 ::-    Monad m-    => E-    -> [([HsPat],E->E)]  -- [(pats,else -> value)]-    -> Ce m [(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 ::-    Monad m-    => [E]               -- input expressions we are matching against.-    -> [([HsPat],E->E)]  -- [(pats,else -> value)]-    -> E                 -- else, what to do if nothing matches-    -> Ce m 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 :: Monad m => [E] -> [([HsPat],E->E)] -> E -> Ce m 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 (APrim (PrimString (packString s)) mempty) [] (rawType "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 => [Type.Rule] -> [(TVr,E)] -> m ([(TVr,E)],Rules)-procAllSpecs 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 (t,e)) rs-            return (unzip hs)-        f _ = return mempty-    (nds,rules) <- mconcat `liftM` mapM f ds-    return $ (nds,fromRules rules)---makeSpec :: Monad m => (TVr,E) -> T.Rule -> m ((TVr,E),Rule)-makeSpec (t,e) T.RuleSpec { T.ruleType = rt, T.ruleUniq = (Module m,ui), T.ruleSuper = ss } = do-    let nt = tipe rt-    as <- specializeE (getType t) nt-    let ntvr = tvr { tvrIdent = toId newName, tvrType = nt, tvrInfo = setProperties (prop_SPECIALIZATION:sspec) mempty }-        Just nn = fromId (tvrIdent t)-        (ntype,Just m,q) = nameParts nn-        newName = toName ntype (Just $ "Spec@." ++ m ++ "." ++ show ui,'f':m ++ "." ++ q)-        sspec = if ss then [prop_SUPERSPECIALIZE] else []-        ar = makeRule ("Specialize.{" ++ show newName) (Module m,ui) RuleSpecialization [] t as (EVar ntvr)-    return ((ntvr,foldl EAp e as),ar)---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 == ErasedAlias = f (eLet v e z) where-        Identity Constructor { conAlias = alias } = getConstructor n dataTable-    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == RecursiveAlias = f $ eLet v (prim_unsafeCoerce e (getType v)) z where-        Identity Constructor { conAlias = alias } = getConstructor n dataTable-    f e = runIdentity $ emapE (return . f) e---
− src/E/Inline.hs 
@@ -1,179 +0,0 @@-module E.Inline(-    app,-    programMapRecGroups,-    forceInline,-    programDecomposedDs,-    programMapProgGroups,-    forceNoinline,-    baseInlinability-    ) where--import Control.Monad.Writer-import Data.Monoid--import StringTable.Atom-import E.Annotate-import E.E-import E.Program-import E.Subst-import E.Values-import Support.FreeVars-import Info.Info(Info)-import Info.Types-import Name.Id-import Options-import Stats-import Util.Graph-import Util.SetLike-import qualified FlagOpts as FO-import qualified Info.Info as Info-------- | 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-    | not (fopts FO.InlinePragmas) = False-    | otherwise  = fromList [prop_INLINE,prop_WRAPPER,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 }--{--The boolean value represents whether the bindings are recursive.--}-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 rec ds = progCombinators_s ds prog {  progType = SubProgram rec, progEntry = fromList (map combIdent ds) }--{--Map recursive program groups.--Consider the program:-x = y-y = z-z = y--This would call 'f [x]' and 'f [y,z]'.--The code is made by the need for substitutions. The names of bindings can't change-but their types or other associated info might.--}-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/LambdaLift.hs 
@@ -1,348 +0,0 @@-module E.LambdaLift(lambdaLift,staticArgumentTransform)  where--import Control.Monad.Reader-import Control.Monad.Writer-import Data.Maybe-import Data.IORef-import Text.Printf-import List hiding(insert)--import Data.DeriveTH-import Data.Derive.All-import StringTable.Atom-import Doc.PPrint-import E.Annotate-import E.E-import E.FreeVars-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 Stats(mtick,runStatM,runStatT)-import Support.CanType-import Support.FreeVars-import Util.Graph as G-import Util.HasSize-import Util.SetLike-import Util.UniqueMonad-import Options (verbose)--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 = programSetDs (concat ds') prog { progStats = progStats prog `mappend` nstat }-    (ds',nstat) = runStatM $ mapM (f True) (programDecomposedDs prog)-    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 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)]-    }-$(derive makeUpdate ''S)--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-    -- We don't want any local functions in the GRIN code.-    let noLift = sempty :: IdSet-    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 | not $ idIsNamed (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) }--}---
− src/E/LetFloat.hs 
@@ -1,349 +0,0 @@-module E.LetFloat(-    atomizeApps,-    atomizeAp,-    floatOutward,-    programFloatInward,-    floatInward-  ) where--import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.Writer-import Data.Monoid-import Data.Typeable-import List  hiding(delete,insert)-import qualified Data.Map as Map--import DataConstructors-import Doc.PPrint-import E.E-import E.FreeVars-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) | isEmptyId i || 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 | getProperty prop_ONESHOT t = True-canFloatPast _ = False--{-# NOINLINE programFloatInward #-}-programFloatInward :: Program -> Program-programFloatInward prog =-    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))-        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-    in 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 [] where--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.reachable (G.newGraph (concatMap G.fromScc xs) (combIdent . fst) (idSetToList . snd)) (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---- This function uses IO to generate new unique names.-floatOutward :: Program -> IO Program-floatOutward prog = do-    -- set natural levels on all types-    let tl (t,e) imap = (tvrInfo_u (Info.insert top_level) t,g top_level e imap)-        g n e@ELam {} imap = foldr ELam (g n' b imap') 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-        g n ec@ECase {} imap = runIdentity $ caseBodiesMapM (\e -> g' n e imap') 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-        g n ELetRec { eDefs = ds, eBody = e } imap = 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 (snds ts), t `notElem` (map (tvrIdent . fst) ts)]-                ts' = [(tvrInfo_u (Info.insert cl . Info.insert n') t,g n e imap') |  (t,e) <- ts]-                imap' = Map.fromList [ (tvrIdent t,n') | t <- fsts ts] `Map.union` imap-            dds [] nrs e imap = ELetRec (concat nrs) (g n e imap)-        g n e imap = runIdentity $ (emapE' (\e -> g' n e imap) e)-        g' n e imap = return $ g n e imap-    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)---    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]---- This function uses IO to generate new unique names.-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/PrimOpt.hs 
@@ -1,208 +0,0 @@-module E.PrimOpt(-    primOpt',-    processPrimPrim-    ) where--import List-import Monad-import Control.Monad.Fix()-import Maybe--import StringTable.Atom-import C.Prims-import C.Arch-import Cmm.OpEval-import DataConstructors-import Data.Monoid-import Doc.DocLike-import Doc.PPrint-import E.E-import E.Values-import GenUtil-import Name.Id-import Stats-import Support.CanType-import Support.FreeVars-import qualified Cmm.Op as Op---{---The primitive operators provided which may be imported into code are--'seq' - evaluate first argument to WHNF, return second one-plus/divide/minus  - perform operation on primitive type-zero/one - the zero and one values for primitive types-const.<foo> - evaluates to the C constant <foo>-error.<err> - equivalent to 'error <err>'-exitFailure__ - abort program immediately with no message-increment/decrement - increment or decrement a primitive numeric type by 1---}---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-    Just (cna,sta,_ta) = lookupCType' dataTable te----cextra Op {} [] = ""-cextra Op {} xs = '.':map f xs where-    f ELit {} = 'c'-    f EPrim {} = 'p'-    f _ = 'e'-cextra _ _ = ""--primConv cop t1 t2 e rt = EPrim (APrim (Op (Op.ConvOp cop t1) t2) mempty) [e] rt--primOpt' dataTable  e@(EPrim (APrim 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 "could noUnt 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' dataTable  n-        Nothing -> return e-primOpt' _ e = return e--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 (APrim Op { primCOp = Op.BinOp bop t1 t2, primRetTy = tr } mempty) [e1, e2] str-    createUnOp bop t1 tr e1 str =-                EPrim (APrim Op { primCOp = Op.UnOp bop t1, primRetTy = tr } mempty) [e1] str-    fromBinOp (EPrim (APrim Op { primCOp = Op.BinOp bop t1 t2, primRetTy = tr } mempty) [e1, e2] str) = Just (bop,t1,t2,tr,e1,e2,str)-    fromBinOp _ = Nothing-    fromUnOp (EPrim (APrim Op { primCOp = Op.UnOp bop t1, primRetTy = tr } mempty) [e1] str) = Just (bop,t1,tr,e1,str)-    fromUnOp _ = Nothing---{---primOpt' dataTable  (EPrim (APrim s _) xs t) | Just n <- primopt s xs t = do-    mtick (toAtom $ "E.PrimOpt." ++ braces (pprint s) ++ cextra s xs )-    primOpt' dataTable  n  where--        -- constant operations-        primopt (Operator "+" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ (ELit (LitInt (l1 + l2) rt))-        primopt (Operator "-" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ (ELit (LitInt (l1 - l2) rt))-        primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ (ELit (LitInt (l1 * l2) rt))-        primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 == l2 then iTrue else iFalse-        primopt (Operator ">=" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 >= l2 then iTrue else iFalse-        primopt (Operator "<=" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 <= l2 then iTrue else iFalse-        primopt (Operator ">" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 > l2 then iTrue else iFalse-        primopt (Operator "<" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 < l2 then iTrue else iFalse-        primopt (Operator "-" [ta] tr) [ELit (LitInt x t)] rt | ta == tr && rt == t = return $ ELit (LitInt (negate x) t)-        -- compare of equals-        primopt (Operator "==" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iTrue-        primopt (Operator ">=" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iTrue-        primopt (Operator "<=" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iTrue-        primopt (Operator ">" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iFalse-        primopt (Operator "<" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iFalse-        -- x + 0 = x-        primopt (Operator "+" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1-        primopt (Operator "+" [ta,tb] tr) [(ELit (LitInt 0 t)),e1] rt  = return $ e1-        -- x * 0 = 0-        primopt (Operator "*" [ta,tb] tr) [_,(ELit (LitInt 0 t))] rt  = return $ (ELit (LitInt 0 t))-        primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt  = return $ (ELit (LitInt 0 t))-        -- x * 1 = x-        primopt (Operator "*" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt  = return $ e1-        primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt 1 t)),e1] rt  = return $ e1-        -- x / 1 = x-        primopt (Operator "/" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt  = return $ e1-        -- x / x = 1  - check for 0 / 0-        --primopt (Operator "/" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return $ (ELit (LitInt 1 rt))-        -- 0 / x = 0  - check for 0 / 0-        --primopt (Operator "/" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt  = return $ (ELit (LitInt 0 t))-        -- x - 0 = x-        primopt (Operator "-" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1-        -- 0 - x = -x-        primopt (Operator "-" [ta,tb] tr) [(ELit (LitInt 0 t)),e1] rt  = return $ EPrim (APrim (Operator "-" [ta] tr) mempty) [e1] rt-        -- x << 0 = x, x >> 0 = x-        primopt (Operator "<<" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1-        primopt (Operator ">>" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1-        -- x % 1 = 0-        primopt (Operator "%" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt  = return $ (ELit (LitInt 0 rt))-        -- x % x = 0 - check for 0 % 0-        --primopt (Operator "%" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return $ (ELit (LitInt 0 rt))-        -- 0 % x = 0 - check for 0 % 0-        --primopt (Operator "%" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt  = return $ (ELit (LitInt 0 t))-        -- eq to case-        primopt (Operator "==" [ta,tb] tr) [e,(ELit (LitInt x t))] rt | isIntegral t  = return $ eCase e [Alt (LitInt x t) iTrue ] iFalse-        primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt x t)),e] rt | isIntegral t = return $ eCase e [Alt (LitInt x t) iTrue ] iFalse-        -- cast of constant-        primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t)  -- TODO ensure constant fits-        primopt _ _ _ = fail "No primitive optimization to apply"-primOpt' _  x = return x--}---processPrimPrim :: DataTable -> E -> E-processPrimPrim dataTable o@(EPrim (APrim (PrimPrim s) _) es orig_t) = maybe o id (primopt (fromAtom s) es (followAliases dataTable orig_t)) where-    primopt "seq" [x,y] _  = return $ prim_seq x y-    primopt "exitFailure__" [w] rt  = return $ EError "" rt-    primopt op [a,b] t | Just cop <- readM op = mdo-        (pa,(ta,sta)) <- extractPrimitive dataTable a-        (pb,(tb,stb)) <- extractPrimitive dataTable b-        (bp,(tr,str)) <- boxPrimitive dataTable-                (EPrim (APrim Op { primCOp = Op.BinOp cop (stringToOpTy ta) (stringToOpTy tb), primRetTy = (stringToOpTy tr) } mempty) [pa, pb] str) t-        return bp-    primopt op [a] t | Just cop <- readM op = mdo-        (pa,(ta,sta)) <- extractPrimitive dataTable a-        (bp,(tr,str)) <- boxPrimitive dataTable-                (EPrim (APrim Op { primCOp = Op.UnOp cop (stringToOpTy ta), primRetTy = (stringToOpTy tr) } mempty) [pa] str) t-        return bp-    primopt op [a] t | Just cop <- readM op = mdo-        (pa,(ta,sta)) <- extractPrimitive dataTable a-        (bp,(tr,str)) <- boxPrimitive dataTable-                (EPrim (APrim Op { primCOp = Op.ConvOp cop (stringToOpTy ta), primRetTy = (stringToOpTy tr) } mempty) [pa] str) t-        return bp-    primopt "constPeekByte" [a] t = return (EPrim (APrim (Peek Op.bits8) mempty) [a] t)-    primopt "box" [a] t = return ans where-        Just (cna,_sta,_ta) = lookupCType' dataTable t-        ans = ELit litCons { litName = cna, litArgs = [a], litType = orig_t }-    primopt "unbox" [a] t = return ans where-        (vara:_) = newIds (freeVars (a,t,orig_t))-        ans = unbox dataTable a vara $ \tvra -> EVar tvra-    primopt op [a] t | Just o <- lookup op unop = do-        (pa,(ta,sta)) <- extractPrimitive dataTable a-        let tvra = tVr vn sta; (vn:_) = newIds (freeVars (a,t))-        (bp,(tr,str)) <- boxPrimitive dataTable (EVar tvra) t-        let res = EPrim (APrim (Op (Op.BinOp o (stringToOpTy ta) (stringToOpTy ta)) (stringToOpTy tr)) mempty) [pa, ELit (LitInt 1 sta)] str-        return $ eStrictLet tvra res bp-        where unop = [("increment",Op.Add),("decrement",Op.Sub),("fincrement",Op.FAdd),("fdecrement",Op.FSub)]-    primopt n [] t | Just num <- lookup n vs = mdo-        (res,(_,sta)) <- boxPrimitive dataTable (ELit (LitInt num sta)) t; return res-        where vs = [("zero",0),("one",1)]-    primopt pn [a,w] t | Just c <- getPrefix "peek." pn      >>= Op.readTy = return (EPrim (APrim (Peek c) mempty) [w,a] t)-    primopt pn [a,v,w] t | Just c <- getPrefix "poke." pn    >>= Op.readTy = return (EPrim (APrim (Poke c) mempty) [w,a,v] t)-    primopt pn [v] t | Just c <- getPrefix "sizeOf." pn      >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c Op.bits32 PrimSizeOf) mempty) [] t)-    primopt pn [v] t | Just c <- getPrefix "alignmentOf." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c Op.bits32 PrimAlignmentOf) mempty) [] t)-    primopt pn [v] t | Just c <- getPrefix "maxBound." pn    >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c c PrimMaxBound) mempty) [] t)-    primopt pn [v] t | Just c <- getPrefix "minBound." pn    >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c c PrimMinBound) mempty) [] t)-    primopt pn [v] t | Just c <- getPrefix "umaxBound." pn   >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c c PrimUMaxBound) mempty) [] t)-    primopt pn [] t | Just c <-  getPrefix "const.M_PI" pn = mdo-        (res,(ta,sta)) <- boxPrimitive dataTable (ELit (LitInt (realToFrac (pi :: Double)) sta)) t; return res-    primopt pn [] t | Just c <-  getPrefix "const." pn = mdo-        (res,(ta,sta)) <- boxPrimitive dataTable (EPrim (APrim (CConst c ta) mempty) [] sta) t; return res-    primopt pn [] _ | Just c <-  getPrefix "error." pn = return (EError c orig_t)-    primopt _ _ _ = fail "not a primopt we care about"-processPrimPrim _ e = e---
− src/E/Program.hs 
@@ -1,155 +0,0 @@-module E.Program where--import Prelude hiding(putStrLn, putStr,print)-import Control.Monad.Identity-import Data.Monoid-import List-import Maybe-import qualified Data.Map as Map--import StringTable.Atom-import DataConstructors-import Doc.DocLike-import Doc.PPrint-import CharIO-import Doc.Pretty-import E.E-import E.Show-import E.Rules ()-import E.TypeCheck-import FrontEnd.Class-import Util.Gen hiding(putErrLn)-import Name.Id-import Name.Name-import Options-import Util.SetLike-import qualified IO-import qualified FlagDump as FD-import qualified Stats---data ProgramType = SubProgram Bool | MainProgram | MainComponent--data Program = Program {-    progExternalNames  :: IdSet,-    progClassHierarchy :: ClassHierarchy,-    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,-    progClassHierarchy = 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 = check $ ucache prog where-    ds = progCombinators prog-    ucache prog = prog { progCombMap = fromList [ (combIdent c,c) | c <- ds ] }-    check x-        | not flint = x-        | hasRepeatUnder combIdent ds = error $ "programSetDs: program has redundant definitions: \n" ++ names-        | any (not . idIsNamed) (map combIdent ds) = error $ "programSetDs: trying to set non unique top level name: \n" ++ names-        | otherwise = x-    names = intercalate "\n"  (sort $ map (show . tvrShowName . combHead) ds)--programSetDs' :: [(TVr,E)] -> Program -> Program-programSetDs' ds prog = progCombinators_s [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- ds ] prog where-    lupRules t = concat [ combRules c | c <- progCombinators prog, combIdent c == t]--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 "") $ map (hPrintComb fh dataTable) cs-    when (not (isEmptyId (progMain prog))) $-        hPutStrLn fh $ "MainEntry: " ++ pprint (progMainEntry prog)-    when (progEntry prog /= singleton (progMain prog)) $-        hPutStrLn fh $ "EntryPoints: " ++ hsep (map pprint (progEntryPoints prog))--printProgram prog = hPrintProgram IO.stderr prog---hPrintComb :: IO.Handle -> DataTable -> Comb -> IO ()-hPrintComb fh dataTable (Comb { combHead = v, combBody = e, combRules = r }) = do-  do wdump FD.Rules $ hPutStrLn fh ("rules: "++show r)-     hPrintCheckName fh dataTable v e---printCheckName'' = hPrintCheckName IO.stderr--hPrintCheckName :: IO.Handle -> DataTable -> TVr -> E -> IO ()-hPrintCheckName fh dataTable tvr e = do-    let (ty,pty) = case 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 (not tmatch || dump FD.EVerbose) $-        hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "::" <+> pty))-    hPutStrLn fh (render $ hang 4 (pprint tvr <+> equals <+> pprint e))
− src/E/Rules.hs 
@@ -1,289 +0,0 @@-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-import qualified Data.Traversable as T-import List-import Maybe--import StringTable.Atom(toAtom)-import Data.Binary-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import E.Binary()-import E.E-import E.Show(render)-import E.Subst-import E.Values-import DataConstructors(typesCompatable)-import GenUtil-import Info.Types-import Name.Id-import Name.Name-import Name.Names-import Options-import Stats-import Support.CanType-import Support.FreeVars-import Util.HasSize-import Util.SetLike as S-import qualified CharIO-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 $ melems 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 $ melems 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' CharIO.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' CharIO.putStr (indent 2 (pprint e1) <+> text "::" <+> ty )-    putDocMLn' CharIO.putStr $ text " ==>" <+> 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 $ munionWith (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 (melems 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-    | Left e <- typesCompatable lty rty =-         error $ render (text "E.Rules.makeRule: type error in rule" <+> text name-                         <$> text e-                         <$> text "in" <+> (align (pprint lhs)-                                            <$> text " :: " <> align (pprint lty))-                         <$> text "==>" <+> (align (pprint body)-                                             <$> text " :: " <> align (pprint rty)))-    | otherwise  = rule-    where-    lhs = (foldl eAp (EVar head) args)-    lty = getType lhs-    rty = getType body-    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 () etherialIds) 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 | isEtherialId i || isEtherialId 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/SSimplify.hs 
@@ -1,1127 +0,0 @@-module E.SSimplify(-    Occurance(..),-    cacheSimpOpts,-    simplifyE,-    collectOccurance',-    programPruneOccurance,-    programSSimplify,-    programSSimplifyPStat,-    SimplifyOpts(..),-    emptySimplifyOpts-    ) where--import Util.RWS-import Control.Monad.Identity-import Control.Monad.Writer-import Control.Monad.Reader-import Data.Typeable-import Data.Monoid-import List hiding(delete,union,insert)-import Data.Maybe-import qualified Data.Set as Set-import qualified Data.Traversable as T--import Data.DeriveTH-import Data.Derive.All-import StringTable.Atom-import C.Prims-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 Cmm.Number-import Options-import Stats hiding(null,new,print,Stats,singleton)-import Support.CanType-import Support.FreeVars-import Util.Graph-import Util.HasSize-import Util.NameMonad-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--import System.Random-import Debug.Trace--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  :: !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 }---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,SetLike,BuildSet (Id,UseInfo),MapLike Id UseInfo,Show,IsEmpty,Eq,Ord)--andOM x y = munionWith 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) }---instance Monoid OMap where-    mempty = OMap mempty-    mappend (OMap a) (OMap b) = OMap (andOM a b)--data Range = Done OutE | Susp InE Subst-    deriving(Show,Eq,Ord)-type Subst = IdMap Range--data Forced = ForceInline | ForceNoinline | NotForced-    deriving(Eq,Ord)--type InE = E-type OutE = E-type InTVr = TVr-type OutTVr = TVr--data Binding =-    NotAmong [Name]-    | IsBoundTo {-        bindingOccurance :: Occurance,-        bindingE :: OutE,-        bindingCheap :: Bool,-        inlineForced :: Forced,-        bindingAtomic :: Bool-        }-    | NotKnown-    deriving(Ord,Eq)--data Env = Env {-    envCachedSubst :: IdMap E,-    envSubst :: Subst,-    envRules :: IdMap ARules,-    envInScope :: IdMap Binding,-    envInScopeCache :: IdMap E-    }-$(derive makeMonoid ''Env)-$(derive makeUpdate ''Env)---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 = n, tvrType =  a} b) | isEmptyId n = 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 (mdelete 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 mdelete avs (map tvrIdent as),fromList $ map tvrIdent as)-            False -> tell $ (inLam $ foldr mdelete 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 $ (mdelete (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 mdelete 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 }--collectDs :: [Comb] -> OMap -> OM [Comb]-collectDs ds (OMap fve) = do-    ds' <- mapM (grump . collectBinding) ds-    exp <- ask-    let graph = newGraph ds' (\ ((comb,_),_) -> combIdent comb) (\ ((_,rv),fv) -> mkeys (fv `mappend` rv))-        rds = reachable graph (mkeys 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) -> mkeys fv)-        (lb,lbds) =  findLoopBreakers (\ ((comb,_),_) -> loopFunc (combHead comb) (combBody comb)) (const True) graph'-        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-        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'''')--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 }----- 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---- 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--orMaps ms = OMap $ fmap orMany $ foldl (munionWith (++)) 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_boundVars :: IdMap Comb,            -- ^ bound variables-    so_forwardVars :: IdSet,               -- ^ variables that we know will exist, but might not yet.--    so_boundVarsCache :: IdSet,-    so_cachedScope :: Env-    }-    {- derive: Monoid -}--emptySimplifyOpts = SimpOpts { so_noInlining  = False-                             , so_finalPhase  = False-                             , so_boundVars   = mempty-                             , so_forwardVars = mempty-                             , 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 -> fixInline (so_finalPhase opts) (combHead c) $ isBoundTo 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---isBoundTo o e = IsBoundTo {-    bindingOccurance = useOccurance o,-    bindingE = e,-    bindingCheap = isCheap e,-    inlineForced = if useOccurance o == LoopBreaker then ForceNoinline else 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 }  where--calcForced finalPhase v =-    let props = getProperties v in-        case (forceNoinline props,finalPhase,forceInline props) of-            (True,_,_) -> ForceNoinline-            (False,True,_) -> NotForced-            (False,False,True) -> ForceInline-            (False,False,False) -> NotForced--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' t _e env | isEmptyId t = env-insertSuspSubst' t e env = cacheSubst env { envSubst = minsert t (susp e (envSubst env)) (envSubst env) }--insertRange :: Id -> Range -> Env -> Env-insertRange t e env | isEmptyId t = 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' t _e env | isEmptyId t = env-insertDoneSubst' t e env = insertRange t (Done e) env---insertInScope :: Id -> Binding -> Env -> Env-insertInScope t _b env | isEmptyId t = 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 `mmember` s || n `mmember` 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) (`mmember` 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)---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' <- primOpt' (progDataTable prog) ep-        ep'' <- dosub ep'-        done cont ep''-    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 (APrim 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 (APrim 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 | idIsNamed 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 = renameSM tvr-    nname tvr@(TVr { tvrIdent = n, tvrType =  t})  = do-        t' <- dosub t-        inb <- ask-        let t'' = substMap' (envInScopeCache inb) t'-        n' <- if isEmptyId n 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; (:) uniq1 uniq2 -> 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') (fixInline finalPhase b' $ isBoundTo 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') (fixInline finalPhase b' $ isBoundTo 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 = n } [] (Just d) | isEmptyId n, 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,i) | isEmptyId i -> do-                        nn <- newName-                        b' <- return b' { tvrIdent = nn }-                        return $ (insertInScope (tvrIdent v) (isBoundTo noUseInfo (EVar b')),b')-                    (EVar v,_) -> return $ (insertDoneSubst b (EVar b') . insertInScope (tvrIdent v) (isBoundTo 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 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 (APrim 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, not (isEmptyId n)]-                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 noUseInfo e) | (e,_,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 (mfindWithDefault 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  -- h x xs inb-            _ -> 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 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-    -- SamB 2009.01.14:-    --   FIXME does this always need to happen? Definately needs to happen sometimes. Without it,-    --   we were getting E type errors in fastest_fib.-    didInline z zs = do-        used <- smUsedNames-        let (ne,nn) = runRename used (foldl EAp z zs)-        smAddNamesIdSet nn-        return ne-    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)-                    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 = fixInline finalPhase t' $ isBoundTo 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' <- sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds']-        return (ds',inb')--{--simplExpr subst ins e = e--simplExprs subst ins ds-    = do --}---- Rename a variable if it shadowes anything from the current scope.--- It is unfortunate that we have to stay in the SM monad for this.-renameSM :: TVr -> SM TVr-renameSM tvr = do env <- ask-                  t' <- dosub (tvrType tvr)-                  inb <- ask-                  let t'' = substMap' (envInScopeCache inb) t'-                  case mmember (tvrIdent tvr) (envInScope env) of-                      False -> return tvr{ tvrType = t''}-                      True  -> do let ns     = genNewId env-                                  return tvr{ tvrIdent = ns-                                            , tvrType = t''}--newNameSM :: (Id -> SM a) -> SM a-newNameSM fn-    = do env <- ask-         let ident  = genNewId env-         localEnv (insertInScope ident NotKnown) (fn ident)--genNewId env = head $ filter (`mnotMember` envInScope env) $ idList-    where idList = map anonymous [2,4..]--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---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 {-    idsUsed :: !IdSet,-    idsBound :: !IdSet,-    smStdGen :: !StdGen-    }--smState = SmState { idsUsed = mempty, idsBound = mempty, smStdGen = mkStdGen 42 }--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 "mtickStat is not defined for SM"--modifyIds fn = SM $ modify f where-    f s@SmState { idsUsed = used, idsBound = bound, smStdGen=gen } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound', smStdGen = gen }-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-        (used,bound) <- getIds-        let genNames i = [st, st + 2 ..]  where-                st = abs i + 2 + abs i `mod` 2---        trace ("newName: "++ show (size used, size bound)) $ return ()-        --newNameFrom  (genNames (size used + size bound))-        sm <- get-        let (g1,g2) = split (smStdGen sm)-        put sm{smStdGen = g1}-        newNameFrom (map anonymous $ filter (>0) $ filter even $ randoms g2)--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-
− src/E/SStrictness.hs 
@@ -1,291 +0,0 @@-module E.SStrictness(-    analyzeProgram-    ) where---import Control.Monad-import Data.List-import Data.FunctorM-import Control.Monad.RWS-import qualified Data.Map as Map-import Data.Typeable--import Doc.PPrint-import E.Program-import Util.SetLike-import Name.Id-import Util.BooleanSolver-import E.E-import Info.Info as Info-import GenUtil---- 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 
@@ -1,277 +0,0 @@-module E.Show(ePretty,render,prettyE,ePrettyEx) where--import Char-import Control.Monad.Identity-import Maybe--import StringTable.Atom-import Doc.Attr-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 Doc.Chars as UC-import qualified FlagDump as FD--{-# NOINLINE render #-}-{-# NOINLINE ePretty #-}-{-# NOINLINE prettyE #-}-{-# NOINLINE ePrettyEx #-}-render :: Doc -> String-render doc =  displayS (renderPretty 100.0 (optColumns options)  doc) ""--prettyE :: E -> String-prettyE e = render $ ePretty e--ePrettyEx = ePretty--showId :: DocLike d => Id -> d-showId i | isEmptyId i = (char '_')-showId i | Just x <- fromId i  = (text $ show x)-showId i = (text $ 'x':show i)--instance DocLike d => PPrint d TVr where-    pprint TVr { tvrIdent = i }  = showId i--instance PPrint Doc E where-    pprint x = ePretty x--instance PPrint String E where-    pprint x = prettyE x--instance PPrint String e => PPrint String (Maybe e) where-    pprint Nothing = "Nothing"-    pprint (Just e) = pprint e--instance PPrint String (Lit E E) where-    pprintPrec 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_Boolzh,["False#","True#"]),-    (toName TypeConstructor ("Lhc.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 const_color = col "blue"-    let --f (LitInt c t) | t == tCharzh = return $ atom $ (const_color (tshow $ chr i)) where-        --    i = fromIntegral c-        f (LitInt i (ELit LitCons { litName = n })) | Just l <- lookup n enumList, i >= 0 && fromIntegral i < length l =-            return $ atom $ (const_color (text $ l !! (fromIntegral i)))-        f (LitInt i _) = return $ atom $ (const_color (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'-        -- Fully-applied tc_Arrows are not good, so make them red so that they are easy to spot-        f LitCons { litName = n, litArgs = [a,b] } | tc_Arrow == n  = do-            a' <- showBind a-            b' <- showBind b-            return $ foldl appCon (atom $ col "red" $ tshow n) [a',b']-        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 = [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-            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-            es' <- mapM showBind es-            return $ foldl appCon (atom (tshow s)) es' -- `inhabit` prettye t-        cons = bop (R,5) (text ":")-    f l--app = bop (L,100) (text " ")-appCon = bop (L,99) (text " ")-col n x = attrColor attr n x-attr = if dump FD.Html then html else ansi--showI i = do-    n <- SEM $ maybeLookupName i-    case n of-        Nothing -> showId 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 | isEmptyId (tvrIdent tvr) = 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 $ idIsNamed (tvrIdent tvr) = do-    SEM $ subVarName $ newName (map (('v':) . show) [1::Int ..]) Unknown (tvrIdent tvr) >> action-allocTVr _ action = action--tBoolzh = ELit litCons { litName = tc_Boolzh, litType = eHash, litAliasFor = Just tIntzh }---- collects lambda and pi abstractions-collectAbstractions e0 = go e0 [] where-    go e1@(EPi tvr e)  xs | isEmptyId (tvrIdent tvr)         = 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)-                                                  -showE :: E -> SEM (Unparse Doc)-showE e = do-    let const_color = col "blue"-    let f e | Just s <- E.E.toString e = return $ atom $ const_color (text $ show s)-        f e | Just xs <- eToList e = do-            xs <- mapM (fmap unparse . showE) xs-            return $ atom $ list xs-        f e | e == tBool     = return $ atom $ text "Bool"-        f e | e == tBoolzh   = return $ atom $ text "Bool#"-        f e | e == tChar     = return $ atom $ text "Char"-        f e | e == tInt      = return $ atom $ text "Int"-        f e | e == tInteger  = return $ atom $ text "Integer"-        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 "World__"-        f e | e == vFalse    = return $ atom $ text "False"-        f e | e == vTrue     = return $ atom $ text "True"-        f e | e == vUnit     = return $ atom $ text "()"-        f (EAp a b) = liftM2 app (showE a) (showE b)-        f (EPi (TVr { tvrIdent = n, tvrType =  e1}) e2) | isEmptyId n = 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 (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 (retOp c <> unparse tvr <> retOp (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 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 (L,(-10)) $ atom $ nest 4 (group ( keyword "let"-                                                                  <$> (align $ sep (map (<> bc ';') 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 (<> bc ';') (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 ((L,(-10))) $ atom $-                group (nest 4 ( keyword "case" <> mbind <+> scrut <+> keyword "of" <$>  (align $ vcat (alts'))) )-        showAlt (Alt l e) = foldr allocTVr ans (litBinds l) where-            ans = do-                l <- showLit showTVr l-                e <- showE e-                return $ fill 10 ((unparse l) <+>  UC.rArrow </> (unparse e))-        showDecl (t,e) = do-            t <- subSEM $ showTVr t-            e <- subSEM $ showE e-            return $ atom $ unparse t <+> retOp (char '=') </> unparse e-        bold' = bold-        bc = bold' . char-        keyword x = col "magenta" (text x)-        symbol x = atom (bold' x)-        arr = bop (R,0) $ retOp (space <> UC.rArrow <> space)-        dot = bop (R,-1) $ retOp (char '.')--        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---retOp x = col "lightgreen" x-inhabit = bop (N,-2) $ retOp UC.coloncolon-bold :: Doc -> Doc-bold = attrBold attr--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 
@@ -1,18 +0,0 @@--- -*- Haskell -*---module E.Show(ePretty,render,prettyE,ePrettyEx) where--import E.E-import Doc.DocLike-import Doc.Pretty-import Doc.PPrint--render :: Doc -> String-prettyE :: E -> String-ePrettyEx :: E -> Doc -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 
@@ -1,293 +0,0 @@-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.Traversable as T-import List hiding(union,insert,delete)--import E.E-import E.FreeVars()-import Name.Id-import Support.FreeVars-import GenUtil-import Util.SetLike as S-import Util.HasSize--import qualified Data.Set as Set--eLetRec :: [(TVr,E)] -> E -> E-eLetRec ds e = f (filter ((not . isEmptyId) . 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 = i }) _ e | isEmptyId i = 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 = i }) _ e | isEmptyId i = 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 (melems im))) e---- | doesn't seed with free variables.-substMap' :: IdMap E -> E -> E-substMap' im = doSubst' False False im (`mmember` im)---- | doesn't seed with free variables.-substMap'' :: IdMap (Maybe E) -> E -> E-substMap'' im = doSubst' False False (mapMaybeIdMap id im) (`mmember` 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) (`mmember` 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 | isEmptyId n || (allShadow && n `notElem` freeVars e) = do-        t' <- f t-        e' <- local (\(s,m) -> (Set.insert n s, mdelete 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 = i, tvrType =  t}) | isEmptyId i = 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) . mdelete 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 + Set.size s + size ss) (not . scheck)-    | isInvalidId i || scheck i = newId (Set.size xs + Set.size s + 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 `mmember` ss || n `member` s || checkTaken n-          check n = scheck n || n `member` xs----eAp (EPi t b) e = if isEmptyId (tvrIdent t) then b else subst t e b-eAp (ELam t b) e = if isEmptyId (tvrIdent t) 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 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 (melems 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 = i, tvrType = t}) e  | isEmptyId i = 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 = i, tvrType =  t}) | isEmptyId i = 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/ToHs.hs 
@@ -1,497 +0,0 @@-module E.ToHs(compileToHs) where--import Char-import Control.Monad.Identity-import Control.Monad-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.Traversable as T-import qualified System-import qualified Data.Set as Set--import Data.DeriveTH-import Data.Derive.All-import PackedString-import C.Prims-import C.Arch-import DataConstructors-import Doc.PPrint-import Doc.DocLike-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 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,"",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,"lhc_Cons"),-        (dc_EmptyList,0,"lhc_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 makeMonoid ''Collect)--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) ""--
− src/E/Traverse.hs 
@@ -1,197 +0,0 @@--module E.Traverse(-    emapE_,-    emapE,-    emapE',-    emapEG,-    emapEGH,-    eSize,-    renameE,-    scopeCheck,-    runRename-    ) where--import Control.Monad.Reader-import Control.Monad.Writer-import Data.Monoid-import Data.Maybe-import qualified Data.Traversable as T--import StringTable.Atom-import E.E-import E.FreeVars(caseUpdate)-import E.Type-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--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 (\(aa,ab) ->do aa <- mapmTvr g aa-                                                                        ab <- f ab-                                                                        return (aa,ab))-                                                         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 = i, tvrType = t} | isEmptyId i = 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 (isEtherialId n) && (not ralways || idIsNamed 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/Type.hs 
@@ -1,283 +0,0 @@--- | The definitions related to lhc core--module E.Type where--import Maybe-import Control.Monad.Identity-import Data.Traversable-import Data.Foldable hiding(concat)-import Control.Applicative---import Data.DeriveTH-import Data.Derive.All-import StringTable.Atom-import C.Prims-import Doc.DocLike hiding((<$>))-import Name.Id-import Util.Gen-import Name.Name-import Name.Names-import Cmm.Number-import Info.Types-import qualified Info.Info as Info--{-@Internals--# Lhc core normalized forms--Lhc 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]-    }--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)--data Alt e = Alt (Lit TVr e) e-    deriving(Eq,Ord)--instance Show e => Show (Alt e) where-    showsPrec n (Alt l e) = showParen (n > 10) $ shows l . showString " -> " . shows e------------------------------------------- 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)---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 APrim [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, Show)------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 = emptyId, tvrType = e} = 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 }--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--$(derive makeUpdate ''TVr')--instance HasProperties TVr where-    modifyProperties f = tvrInfo_u (modifyProperties f)-    getProperties = getProperties . tvrInfo-    putProperties prop =  tvrInfo_u (putProperties prop)----instance FunctorM TVr' where---    fmapM f t = do e <- f (tvrType t); return t { tvrType = e }---instance Functor TVr' where---    fmap f t = runIdentity (fmapM (return . f) t)----- 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 }--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)-combArgs  = snd . fromLam . combBody-combABody = fst . fromLam . combBody-emptyComb = Comb { combHead = tvr, combBody = Unknown, combRules = [] }-combIdent = tvrIdent . combHead-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 }--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---$(derive makeIs ''Lit)-$(derive makeFunctor ''Lit)-$(derive makeFoldable ''Lit)-$(derive makeTraversable ''Lit)-$(derive makeIs ''ESort)-$(derive makeIs ''E)-$(derive makeFrom ''E)-$(derive makeFunctor ''TVr')-$(derive makeFoldable ''TVr')-$(derive makeTraversable ''TVr')
− src/E/TypeAnalysis.hs 
@@ -1,448 +0,0 @@--- | 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.Monoid-import Data.Maybe-import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Data.Foldable as T--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-import qualified Stats-import qualified Info.Info as Info---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-            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---getValue e = fail $ "getValue: " ++ show e--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  -- TODO - absurdize values properly-    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 doSpecialize env comb = do-    ((t,e),nds) <- specializeDef doSpecialize env (combHead comb,combBody comb)-    return (combHead_s t . combBody_s e $ comb,nds)--}--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 = 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---caseCast t _ty e = e--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"----{----- pruning the unused branches of typecase statements---pruneE :: E -> IO E-pruneE e = return $ runIdentity (prune e)  where-    prune ec@ECase { eCaseScrutinee = EVar v } | sortKindLike (getType v), Just vm <- Info.lookup (tvrInfo v) = do-        ec' <- pruneCase ec vm-        emapE' prune ec'-    prune e = emapE' prune e--pruneCase :: (Monad m) => E -> VMap () Name -> m E-pruneCase ec ns = return $ if null (caseBodies nec) then err else nec where-    err = EError "pruneCase: all alternatives pruned" (getType ec)-    nec = caseUpdate ec { eCaseAlts = f [] $ eCaseAlts ec, eCaseDefault = cd (eCaseDefault ec)}-    f xs [] = reverse xs-    f xs (alt@(Alt LitCons { litName = n } _):rs) | not (n `vmapMember` ns) = f xs rs-    f xs (alt:rs) = f (alt:xs) rs-    cd (Just d) | Just nns <- vmapHeads ns, or [ n `notElem` as | n <- nns ] = Just d-                | Nothing <- vmapHeads ns = Just d-    cd Nothing = Nothing-    -- The reason we do this is because for a typecase, we need a valid default in order to get the most general type-    cd (Just d) = Just $ EError "pruneCase: default pruned" (getType d)-    as = [ n | LitCons { litName = n } <- casePats ec ]---}
− src/E/TypeCheck.hs 
@@ -1,476 +0,0 @@-module E.TypeCheck(-    canBeBox,-    eAp,-    inferType,-    match,-    sortSortLike,-    sortKindLike,-    sortTermLike,-    sortTypeLike,-    typeInfer,-    typeInfer'-    ) where--import Control.Monad.Reader-import Control.Monad.Writer-import Monad(when,liftM)-import qualified Data.Map as Map--import Data.DeriveTH-import Data.Derive.All-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import E.E-import E.Eval(strong)-import {-# SOURCE #-} E.Show-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---{-@Internals--# Lhc Core Type System--Lhc'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. Lhc's version is-described by the following.--    Sorts  = (*,!,**,#,(#),##)-    Axioms = (*::**,#::##,(#)::##,!::**)---    *   is the sort of boxed values-    !   is the sort of boxed strict values-    **  is the supersort of all boxed value-    #   is the sort of unboxed values-    (#) is the sort of unboxed tuples-    ##  is the supersort of all unboxed values--    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.-(TODO: explain strict in this context) These type system rules apply to lambda-abstractions. it is possible to inherit values from the environment that would-not be typable via lambda abstractions. for instance, although a data-constructor may have a functional type, it was not created via a lambda-abstraction so these rules do not apply.--    as a shortcut we will use *# to mean either * or # and so forth-    so (*#,*#,*) means (*,*,*) (#,*,*) (*,#,*) (#,#,*)--    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-       (**,##,##)  -- Array__ a :: #--    The defining feature of boxed values is--    _|_ :: t iff t::*--    This PTS is functional but not injective---}---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)-        ]---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 E where-    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 $ "getType: " ++ show e) 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 $ 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 ESort where-    getType (ESortNamed _) = EHashHash-    getType s = case Map.lookup s ptsAxioms of-        Just s -> s-        Nothing -> error $ "getType: " ++ show s-instance CanType TVr E where-    getType = tvrType-instance CanType (Lit x t) t where-    getType l = litType l-instance CanType e t => CanType (Alt e) t where-    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---- Lemmih 08.11.25: Why use a list instead of map? This list is always null, btw.--- | Perform a full typecheck, evaluating type terms as necessary.--inferType :: ContextMonad String m => DataTable -> [(TVr,E)] -> E -> m E-inferType dataTable ds e = rfc e where-    inferType' ds e = inferType dataTable ds e-    prettyE = ePrettyEx-    rfc e =  withContextDoc (text "fullCheck:" </> prettyE e) (fc e >>=  strong')-    rfc' nds e = withContextDoc (text "fullCheck(nested):" </> prettyE e) (inferType' nds e >>=  strong')-    strong' e = withContextDoc (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 (ELit LitCons { litName = n, litArgs = es, litType =  t}) = do-        withContext ("Checking Constructor: " ++ show n) $ do-        valid t-        es' <- mapM rfc es-        t' <- strong' t-        let sts = slotTypes dataTable n t-            les = length es-            lsts = length sts-        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-    -- Lemmih 08.11.26: Why are unnamed bindings errors in this case?-    fc (EVar (TVr { tvrIdent = i })) | isEmptyId i = 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-        valid at-        b' <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b-        strong' $ EPi tvr b'-    fc (EAp (EPi tvr e) 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-        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 = i },_) | isEmptyId i = 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"-        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.-        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.-        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 <- mapM (strong' . getType) $ casePats ec-        withContext "checking typelike pattern equality" $ eqAll (et:ps)-        strong' dt-    fc ec@ECase { eCaseScrutinee =e, eCaseBind = b } = 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 (not . isEmptyId) $ 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-            Right () -> return (e1)-            Left s -> failDoc $ text "eq:" <+> align $ vcat [ text s, 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---instance CanTypeCheck DataTable E E where-    typecheck dataTable e = case typeInfer'' dataTable [] e of-        Left ss -> fail $ "\n>>> internal error:\n" ++ unlines (tail ss)-        Right v -> return v--instance CanTypeCheck DataTable TVr E where-    typecheck dt tvr = do-        typecheck dt (getType tvr)-        return $ getType tvr--instance CanTypeCheck DataTable (Lit a E) 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 DataTable (Alt E) E where-    typecheck dt (Alt l e) = typecheck dt l >> typecheck dt e--instance CanTypeCheck DataTable [(TVr,E)] [E] where-    typecheck dataTable ds = do mapM (typecheck dataTable) (snds ds)--data TcEnv = TcEnv {-    tcDefns :: [(TVr,E)],-    tcContext :: [String],-    tcDataTable :: DataTable-    }---- | 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 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 typeInfer'' dataTable ds e of-    Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss)-    Right v -> v--newtype Tc a = Tc (Reader TcEnv a)-    deriving(Monad,Functor,MonadReader TcEnv)--typeInfer'' :: ContextMonad String m => 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':" </> ePrettyEx e) (fc e >>=  strong')-    rfc' nds e =  withContextDoc (text "fullCheck'(nested):" </> ePrettyEx e) (inferType' nds  e >>=  strong')-    strong' e = withContextDoc (text "Strong':" </> ePrettyEx 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 = i }) | isEmptyId i = 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-    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? " </> (ePrettyEx 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 () (etherialIds)) 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 | isEtherialId i || isEtherialId 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--$(derive makeUpdate ''TcEnv)-instance ContextMonad String Tc where-    withContext s = local (tcContext_u (s:))--tcE :: E -> Tc E-tcE e = rfc e where-    rfc e =  withContextDoc (text "tcE:" </> ePrettyEx e) (fc e >>=  strong')-    strong' e = do-        ds <- asks tcDefns-        withContextDoc (text "tcE.strong:" </> ePrettyEx 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 = i }) | isEmptyId i = 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? " </> (ePrettyEx e)-
− src/E/Values.hs 
@@ -1,314 +0,0 @@-module E.Values where--import Char-import Control.Monad.Identity-import Data.Monoid-import List-import Ratio--import C.Prims-import E.E-import E.FreeVars()-import E.Subst-import E.TypeCheck-import Info.Types-import Info.Info(HasInfo(..))-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_Rational, 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 = vCons, litArgs = [x,xs], litType = getType xs }-eNil t = ELit $ litCons { litName = vEmptyList, 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] -- ELit litCons { litName = dc_JustIO, litArgs = [w,x], litType = ELit litCons { litName = tc_IOResult, litArgs = [getType x], litType = eStar } }-tIO t = ELit (litCons { litName = tc_IO, litArgs = [t], litType = eStar })--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 = i } _ e' | isEmptyId i = 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 ((not . isEmptyId) . 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 ((not . isEmptyId) . 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"--rawType s = ELit litCons { litName = toName RawType s, litType = eHash }--tWorldzh = ELit litCons { litName = tc_World__, litArgs = [], litType = eHash }--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 (APrim 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 _ _) = aprimIsCheap 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, aprimIsCheap p = all safeToDup (caseBodies ec)-safeToDup (EPrim p _ _) = aprimIsCheap p-safeToDup e = whnfOrBot e || isELam e || isEPi e--tBoolzh = ELit litCons { litName = tc_Boolzh, litType = eHash, litAliasFor = Just tEnumzh }--lFalsezh = (LitInt 0 tBoolzh)-lTruezh = (LitInt 1 tBoolzh)---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 
@@ -1,165 +0,0 @@-module E.WorkerWrapper(performWorkWrap,workWrapProgram) where--import Control.Monad.Writer hiding(Product(..))-import Data.Monoid hiding(Product(..))-import Maybe-import Monad--import DataConstructors-import E.CPR-import E.E-import E.FreeVars-import E.Program-import E.Traverse-import E.TypeCheck()-import E.Values-import GenUtil-import Info.Types-import Name.Name-import Name.Names-import Name.Id (isEmptyId, fromId, toId)-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 = i } _ | isEmptyId i = (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 
@@ -1,82 +0,0 @@-module FindFixpoint(Ms, getVal, solve) where--import Array-import CharIO-import Control.Monad.Writer-import Data.Array.IO-import Data.Graph-import Data.IntSet as IntSet-import GenUtil-import Monad(liftM)------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' (\_ -> (CharIO.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 _ -> CharIO.putErrLn-            Nothing -> const (return ())-        put' = case str' of-            Just _ -> CharIO.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 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 
@@ -1,310 +0,0 @@-{-# LANGUAGE BangPatterns, ExistentialQuantification, DeriveDataTypeable #-}--- 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 IO(hFlush, stdout, Handle, hPutStr)-import 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 :: !(IORef [MkFixable]),-    todo :: !(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 :: {-# UNPACK #-} !Unique,-    action :: !(IORef [a -> IO ()]),-    pending :: !(IORef a),-    current :: !(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` 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 
@@ -1,52 +0,0 @@-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 (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 
@@ -1,110 +0,0 @@-module Fixer.VMap(-    VMap(),-    Proxy(..),-    vmapSingleton,-    vmapArgSingleton,-    vmapArg,-    vmapValue,-    vmapMember,-    vmapProxyIndirect,-    vmapPlaceholder,-    vmapDropArgs,-    vmapHeads-    )where--import Data.Monoid-import Data.Typeable-import List(intersperse)-import qualified Data.Map as Map-import qualified Data.Set as Set--import Doc.DocLike-import Fixer.Fixer-import GenUtil----- VMap 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 a,Ord b) => VMap a b-emptyVMap = VMap { vmapArgs = mempty, vmapNodes = Right mempty }--vmapSingleton n = emptyVMap { vmapNodes = Right $ Set.singleton n }--vmapArgSingleton n i v-    | isBottom v = emptyVMap-    | otherwise = pruneVMap $ emptyVMap { vmapArgs = Map.singleton (n,i) v }--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 vm = vm { vmapArgs = mempty }--vmapHeads VMap { vmapNodes = Left _ } = fail "vmapHeads: VMap is unknown"-vmapHeads VMap { vmapNodes = Right set } = return $ Set.toList set--vmapMember n VMap { vmapNodes = Left _ } = True-vmapMember n VMap { vmapNodes = Right set } = n `Set.member` set---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 
@@ -1,259 +0,0 @@-module FlagDump(Flag(..),process,helpMsg,helpFlags) where--import qualified Data.Set as Set---- | Flags-data Flag =-      AllDcons          -- ^ show unified data constructor table-    | AllKind           -- ^ show unified kind table after everything has been typechecked-    | AllTypes          -- ^ show unified type table, after everything has been typechecked-    | Aspats            -- ^ show as patterns-    | Bindgroups        -- ^ show bindgroups-    | BoxySteps         -- ^ show step by step what the type inferencer is doing-    | 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-    | Dcons             -- ^ data constructors-    | Decls             -- ^ processed declarations-    | Defs              -- ^ Show all defined names in a module-    | DepGraph          -- ^ Dump module dependancy graph to deps.dot-    | 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-    | Eval              -- ^ show detailed eval inlining info-    | Exports           -- ^ show which names are exported from each module-    | Grin              -- ^ show final grin code-    | 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-    | GrinPass          -- ^ show each iteration of code while transforming-    | GrinPosteval      -- ^ show grin code just before eval\/apply inlining-    | GrinPreeval       -- ^ show grin code just before eval\/apply inlining-    | GrinSteps         -- ^ show what happens in each transformation-    | Html              -- ^ use html escape codes in output-    | Imports           -- ^ show in scope names for each module-    | 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-    | SquareStats       -- ^ use square corners (this is now the only option, though)-    | 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-    | Tyvar             -- ^ show original tyvars rather than renaming them.-    deriving(Eq,Ord,Bounded)--instance Show Flag where-    show The = "the"-    show Preprocessed = "preprocessed"-    show Renamed = "renamed"-    show Parsed = "parsed"-    show Derived = "derived"-    show Imports = "imports"-    show Exports = "exports"-    show SccModules = "scc-modules"-    show DepGraph = "dep-graph"-    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 AllKind = "all-kind"-    show AllDcons = "all-dcons"-    show AllTypes = "all-types"-    show Sigenv = "sigenv"-    show Srcsigs = "srcsigs"-    show Program = "program"-    show Decls = "decls"-    show BoxySteps = "boxy-steps"-    show Aspats = "aspats"-    show Tyvar = "tyvar"-    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 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 GrinPreeval = "grin-preeval"-    show GrinPosteval = "grin-posteval"-    show Grin = "grin"-    show GrinInitial = "grin-initial"-    show GrinNormalized = "grin-normalized"-    show Steps = "steps"-    show Eval = "eval"-    show GrinPass = "grin-pass"-    show GrinSteps = "grin-steps"-    show GrinGraph = "grin-graph"-    show Progress = "progress"-    show Stats = "stats"-    show Html = "html"-    show SquareStats = "square-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 "program" = Right $ Set.insert Program-one "no-program" = Right $ Set.delete Program-one "grin-preeval" = Right $ Set.insert GrinPreeval-one "no-grin-preeval" = Right $ Set.delete GrinPreeval-one "tyvar" = Right $ Set.insert Tyvar-one "no-tyvar" = Right $ Set.delete Tyvar-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 "aspats" = Right $ Set.insert Aspats-one "no-aspats" = Right $ Set.delete Aspats-one "all-dcons" = Right $ Set.insert AllDcons-one "no-all-dcons" = Right $ Set.delete AllDcons-one "all-kind" = Right $ Set.insert AllKind-one "no-all-kind" = Right $ Set.delete AllKind-one "instance" = Right $ Set.insert Instance-one "no-instance" = Right $ Set.delete Instance-one "square-stats" = Right $ Set.insert SquareStats-one "no-square-stats" = Right $ Set.delete SquareStats-one "defs" = Right $ Set.insert Defs-one "no-defs" = Right $ Set.delete Defs-one "e-size" = Right $ Set.insert ESize-one "no-e-size" = Right $ Set.delete ESize-one "grin-pass" = Right $ Set.insert GrinPass-one "no-grin-pass" = Right $ Set.delete GrinPass-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 "core" = Right $ Set.insert Core-one "no-core" = Right $ Set.delete Core-one "types" = Right $ Set.insert Types-one "no-types" = Right $ Set.delete Types-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 "html" = Right $ Set.insert Html-one "no-html" = Right $ Set.delete Html-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 "grin-steps" = Right $ Set.insert GrinSteps-one "no-grin-steps" = Right $ Set.delete GrinSteps-one "dcons" = Right $ Set.insert Dcons-one "no-dcons" = Right $ Set.delete Dcons-one "eval" = Right $ Set.insert Eval-one "no-eval" = Right $ Set.delete Eval-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 "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 "dep-graph" = Right $ Set.insert DepGraph-one "no-dep-graph" = Right $ Set.delete DepGraph-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 --\n defs\n    Show all defined names in a module\n dep-graph\n    Dump module dependancy graph to deps.dot\n derived\n    show generated derived instances\n exports\n    show which names are exported from each module\n imports\n    show in scope names for each module\n parsed\n    parsed code\n preprocessed\n    code after preprocessing/deliting\n renamed\n    code after uniqueness renaming\n scc-modules\n    show strongly connected modules in dependency order\n\n-- Type Checker --\n all-dcons\n    show unified data constructor table\n all-kind\n    show unified kind table after everything has been typechecked\n all-types\n    show unified type table, after everything has been typechecked\n aspats\n    show as patterns\n bindgroups\n    show bindgroups\n boxy-steps\n    show step by step what the type inferencer is doing\n class\n    detailed information on each class\n class-summary\n    summary of all classes\n dcons\n    data constructors\n decls\n    processed declarations\n instance\n    show instances\n kind\n    show results of kind inference for each module\n kind-steps\n    show steps of kind inference\n program\n    impl expls, the whole shebang.\n sigenv\n    initial signature environment\n srcsigs\n    processed signatures from source code\n types\n    display unified type table containing all defined names\n tyvar\n    show original tyvars rather than renaming them.\n\n-- Intermediate code --\n core\n    show intermediate core code\n core-afterlift\n    show final core before writing ho file\n core-beforelift\n    show core before lambda lifting\n core-initial\n    show core right after E.FromHs conversion\n core-mangled\n    de-typed core right before it is converted to grin\n core-mini\n    show details even when optimizing individual functions\n core-pass\n    show each iteration of code while transforming\n core-steps\n    show what happens in each pass\n datatable\n    show data table of constructors\n e-alias\n    show expanded aliases\n e-info\n    show info tags on all bound variables\n e-size\n    print the size of E after each pass\n e-verbose\n    print very verbose version of E code always\n optimization-stats\n    show combined stats of optimization passes\n rules\n    show all user rules and catalysts\n rules-spec\n    show specialization rules\n\n-- Grin code --\n eval\n    show detailed eval inlining info\n grin\n    show final grin code\n grin-graph\n    print dot file of final grin code to outputname_grin.dot\n grin-initial\n    grin right after conversion from core\n grin-normalized\n    grin right after first normalization\n grin-pass\n    show each iteration of code while transforming\n grin-posteval\n    show grin code just before eval/apply inlining\n grin-preeval\n    show grin code just before eval/apply inlining\n grin-steps\n    show what happens in each transformation\n steps\n    show interpreter go\n tags\n    list of all tags and their types\n\n-- General --\n html\n    use html escape codes in output\n progress\n    show basic progress indicators\n square-stats\n    use square corners (this is now the only option, though)\n stats\n    show extra information about stuff\n verbose\n    progress\n veryverbose\n    progress stats\n"-helpFlags = ["all-dcons", "all-kind", "all-types", "aspats", "bindgroups", "boxy-steps", "class", "class-summary", "core", "core-afterlift", "core-beforelift", "core-initial", "core-mangled", "core-mini", "core-pass", "core-steps", "datatable", "dcons", "decls", "defs", "dep-graph", "derived", "e-alias", "e-info", "e-size", "e-verbose", "eval", "exports", "grin", "grin-graph", "grin-initial", "grin-normalized", "grin-pass", "grin-posteval", "grin-preeval", "grin-steps", "html", "imports", "instance", "kind", "kind-steps", "optimization-stats", "parsed", "preprocessed", "program", "progress", "renamed", "rules", "rules-spec", "scc-modules", "sigenv", "square-stats", "srcsigs", "stats", "steps", "tags", "the", "types", "tyvar", "verbose", "veryverbose"]-
− src/FlagOpts.hs 
@@ -1,114 +0,0 @@-module FlagOpts(Flag(..),process,helpMsg,helpFlags) where--import qualified Data.Set as Set---- | Flags-data Flag =-      Boehm             -- ^ use Boehm garbage collector-    | Controlled        -- ^ with the '-f' flag, the following options are availible, you can-    | Cpp               -- ^ pass haskell source through c preprocessor-    | Cpr               -- ^ do CPR analysis-    | Debug             -- ^ enable debugging code in generated executable-    | Defaulting        -- ^ perform defaulting of ambiguous types-    | Ffi               -- ^ support foreign function declarations-    | FloatIn           -- ^ perform float inward transform-    | GlobalOptimize    -- ^ perform whole program E optimization-    | InlinePragmas     -- ^ use inline pragmas-    | 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.-    | Profile           -- ^ enable profiling code in generated executable-    | Raw               -- ^ just evaluate main to WHNF and nothing else.-    | Rules             -- ^ use rules-    | Strictness        -- ^ perform strictness analysis-    | TypeAnalysis      -- ^ perhaps a basic points-to analysis on types right after method generation-    | UnboxedTuples     -- ^ allow unboxed tuple syntax to be recognized-    | UnboxedValues     -- ^ allow unboxed value syntax-    | Unsafe            -- ^ disable runtime assertions-    | 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 Unsafe = "unsafe"-    show MonomorphismRestriction = "monomorphism-restriction"-    show Defaulting = "defaulting"-    show Lint = "lint"-    show InlinePragmas = "inline-pragmas"-    show Rules = "rules"-    show FloatIn = "float-in"-    show Strictness = "strictness"-    show Cpr = "cpr"-    show TypeAnalysis = "type-analysis"-    show GlobalOptimize = "global-optimize"-    show Wrapper = "wrapper"-    show Boehm = "boehm"-    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 "cpr" = Right $ Set.insert Cpr-one "no-cpr" = Right $ Set.delete Cpr-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 "strictness" = Right $ Set.insert Strictness-one "no-strictness" = Right $ Set.delete Strictness-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 "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 "unsafe" = Right $ Set.insert Unsafe-one "no-unsafe" = Right $ Set.delete Unsafe-one "float-in" = Right $ Set.insert FloatIn-one "no-float-in" = Right $ Set.delete FloatIn-one "unboxed-values" = Right $ Set.insert UnboxedValues-one "no-unboxed-values" = Right $ Set.delete UnboxedValues-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 "default" = Right $ foldr (.) id [ f | Right f <- [ one "inline-pragmas",one "rules",one "wrapper",one "float-in",one "strictness",one "defaulting",one "type-analysis",one "monomorphism-restriction",one "boxy",one "eval-optimize",one "global-optimize"]]-one "negate" = Right $ Set.insert Negate-one "no-negate" = Right $ Set.delete Negate-one "cpp" = Right $ Set.insert Cpp-one "no-cpp" = Right $ Set.delete Cpp-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 --\n cpp\n    pass haskell source through c preprocessor\n ffi\n    support foreign function declarations\n m4\n    pass haskell source through m4 preprocessor\n unboxed-tuples\n    allow unboxed tuple syntax to be recognized\n unboxed-values\n    allow unboxed value syntax\n unsafe\n    disable runtime assertions\n\n-- Typechecking --\n defaulting\n    perform defaulting of ambiguous types\n monomorphism-restriction\n    enforce monomorphism restriction\n\n-- Debugging --\n lint\n    perform lots of extra type checks\n\n-- Optimization Options --\n cpr\n    do CPR analysis\n float-in\n    perform float inward transform\n global-optimize\n    perform whole program E optimization\n inline-pragmas\n    use inline pragmas\n rules\n    use rules\n strictness\n    perform strictness analysis\n type-analysis\n    perhaps a basic points-to analysis on types right after method generation\n\n-- Code Generation --\n boehm\n    use Boehm garbage collector\n debug\n    enable debugging code in generated executable\n profile\n    enable profiling code in generated executable\n raw\n    just evaluate main to WHNF and nothing else.\n wrapper\n    wrap main in exception handler\n\n-- Default settings --\n default\n    inline-pragmas rules wrapper float-in strictness defaulting type-analysis monomorphism-restriction boxy eval-optimize global-optimize\n"-helpFlags = ["boehm", "controlled", "cpp", "cpr", "debug", "default", "defaulting", "ffi", "float-in", "global-optimize", "inline-pragmas", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "unsafe", "wrapper"]-
− src/FrontEnd/Class.hs 
@@ -1,564 +0,0 @@-module FrontEnd.Class(-    printClassHierarchy,-    instanceToTopDecls,-    ClassHierarchy,-    ClassRecord(..),-    isClassRecord,-    instanceName,-    defaultInstanceName,-    printClassSummary,-    findClassRecord,-    asksClassRecord,-    classRecords,-    makeClassHierarchy,-    derivableClasses,-    makeInstanceEnv,-    InstanceEnv(..),-    Inst(..)-    ) where--import Data.DeriveTH-import Data.Derive.All-import Control.Arrow (first)-import Control.Monad.Identity-import Control.Monad.Writer-import Data.Monoid-import Data.Generics-import Data.List(nub,(\\))-import Text.PrettyPrint.ANSI.Leijen(Doc())-import qualified Data.Map as Map-import Debug.Trace--import Data.Binary-import Doc.DocLike-import Doc.PPrint-import FrontEnd.KindInfer-import FrontEnd.Tc.Kind-import FrontEnd.SrcLoc-import FrontEnd.Tc.Type-import FrontEnd.Utils-import FrontEnd.HsSyn-import Maybe-import Monad-import Name.Name-import Name.Names-import Support.CanType-import Support.FreeVars-import Util.Gen-import Util.HasSize-import Util.Inst()-import Support.Tickle-import Options (verbose)------------------------------------------------------------------------------------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 makeBinary ''Inst)--instance PPrint a (Qual Pred) => PPrint a Inst where-    pprint Inst { instHead = h, instAssocs = [] } = pprint h-    pprint Inst { instHead = h, instAssocs = as } = -        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 = [] }---- | a class record is either a class along with instances, or just instances.--- you can tell the difference by the presence of the classArgs field--data ClassRecord = ClassRecord      { className :: Class,-                                      classSrcLoc :: SrcLoc,-                                      classArgs :: [Tyvar],-                                      classSupers :: [Class],-                                      classInsts :: [Inst],-                                      classAssumps :: [(Name,Sigma)], -- ^ method signatures-                                      classDefaults :: [(Name,Name)], -- ^ default methods and their body names-                                      classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)]-                                    }-    deriving Show-$(derive makeBinary ''ClassRecord)-$(derive makeIs ''ClassRecord)--newClassRecord c = ClassRecord {-    className = c,-    classSrcLoc = bogusASrcLoc,-    classSupers = [],-    classArgs = [],-    classInsts = [],-    classAssumps = [],-    classDefaults = [],-    classAssocs = []-    }---- SamB 2009-01-17: Why all the snubbing? Most of these fields should be blank on one side shouldn't they?-combineClassRecords cra@(ClassRecord {}) crb@(ClassRecord {})-    | className cra == className crb = ClassRecord {-    className = className cra,-    classSrcLoc = if classSrcLoc cra == bogusASrcLoc then classSrcLoc crb else classSrcLoc cra,-    classSupers = snub $ classSupers cra ++ classSupers crb,-    classInsts = snub $ classInsts cra ++ classInsts crb,-    classAssumps = snubFst $ classAssumps cra ++ classAssumps crb,-    classAssocs = snubUnder fst3 $ classAssocs cra ++ classAssocs crb,-    classDefaults = snub $ classDefaults cra ++ classDefaults crb,-    classArgs = if null (classArgs cra) then classArgs crb else classArgs cra-    }--newtype InstanceEnv = InstanceEnv { instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) }--makeInstanceEnv :: ClassHierarchy -> InstanceEnv-makeInstanceEnv (ClassHierarchy ch) = InstanceEnv $ Map.fromList (concatMap f (Map.elems ch)) where-    f cr = concatMap (g cr) (classInsts cr)-    g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == className cr = ans where-        ans = [ ((tyconName tc,getTypeHead tt),(is,rs,e)) | (tc,is,rs,e) <- as]-    g cr x = error $  "makeInstanceEnv: " ++ show (className cr,x)--getTypeHead th = case fromTAp th of-    (TArrow {},_) -> tc_Arrow-    (TCon c,_) -> tyconName c-    _ -> error $ "getTypeHead: " ++ show th--newtype ClassHierarchy = ClassHierarchy (Map.Map Class ClassRecord)-    deriving (HasSize)--instance Binary ClassHierarchy where-    get = fmap ClassHierarchy get-    put (ClassHierarchy ch) = put ch--instance Monoid ClassHierarchy where-    mempty = ClassHierarchy mempty-    mappend (ClassHierarchy a) (ClassHierarchy b) = ClassHierarchy $ Map.unionWith combineClassRecords a b--classRecords :: ClassHierarchy -> [ClassRecord]-classRecords (ClassHierarchy ch) = Map.elems ch--findClassRecord (ClassHierarchy ch) cn = case Map.lookup cn ch of-    Nothing -> error $ "findClassRecord: " ++ show cn-    Just n -> n--asksClassRecord (ClassHierarchy ch) cn f = case Map.lookup cn ch of-    Nothing -> error $ "asksClassRecord: " ++ show cn-    Just n -> f n--showInst :: Inst -> String-showInst x = show (pprint x :: Doc)---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 (ClassHierarchy h) = mapM_ f $  h' where-    h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ]-    f (cname, (ClassRecord { classSupers = supers, classInsts = insts, classAssumps = ma})) = do-        putStrLn $ "-- class: " ++ show cname-        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)-        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))-        putStrLn ""----printClassHierarchy :: ClassHierarchy -> IO ()-printClassHierarchy (ClassHierarchy h) = mapM_ printClassDetails $  Map.toList h where-    printClassDetails :: (Name, ClassRecord) -> IO ()-    printClassDetails (cname, cr) = do-        let args = classArgs cr; supers = classSupers cr; insts = classInsts cr;-            defaults = classDefaults cr-            methodAssumps = classAssumps cr-            assocs = classAssocs cr-        putStrLn "..........."-        putStrLn $ "class: " ++ hsep (pprint cname:map pprint args)-        putStr $ "super classes:"-        pnone supers $ do putStrLn $ " " ++ (intercalate " " (map show supers))-        putStr $ "instances:"-        pnone insts $  putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)-        putStr $ "default method implementations:"-        pnone defaults $ putStr $ "\n" ++ (unlines $ map pretty defaults)-        when (isClassRecord cr) $ do-            putStr $ "method signatures:"-            pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps)-            putStr $ "associated types:"-            pnone assocs $  putStrLn $ "\n" ++ (unlines $ map (show . passoc) assocs)-    pnone [] f = putStrLn " none"-    pnone xs f = f-    passoc (nk,as,mt) = text "type" <+> pprint nk <+> hsep (map pprint as) <> case mt of-        Nothing -> empty :: Doc-        Just s -> text " = " <> pprint s---------------------------------------------------------------------------------------modifyClassRecord ::  (ClassRecord -> ClassRecord) -> Class -> ClassHierarchy -> ClassHierarchy-modifyClassRecord f c (ClassHierarchy h) = case Map.lookup c h of-           --Nothing -> error $ "modifyClassRecord: " ++ show c-           Nothing -> ClassHierarchy $ Map.insert c (f (newClassRecord c)) h-           Just r -> ClassHierarchy $ Map.insert c (f r) h--addOneInstanceToHierarchy :: ClassHierarchy -> Inst -> ClassHierarchy-addOneInstanceToHierarchy ch inst@Inst { instHead = cntxt :=> IsIn className _ } -   = modifyClassRecord f className ch-    where-    f c = c { classInsts = inst:classInsts c }---hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst]-hsInstDeclToInst kt (HsInstDecl sloc qType decls)-   | length classKind == length argTypeKind, and subsumptions-        = return [emptyInstance { instSrcLoc = sloc,-                                  instDerived = False,-                                  instHead = cntxt :=> IsIn className convertedArgType,-                                  instAssocs = assocs }]-   | otherwise = failSl sloc $ "hsInstDeclToInst: kind error, attempt to make\n" ++-                      show convertedArgType ++ " (with kind " ++ show argTypeKind ++ ")\n" ++-                      "an instance of class " ++ show className ++-                      " (with kind " ++ show classKind ++ ") " ++ show subsumptions-   where-   (cntxt, (className, cargs@[convertedArgType])) = qtToClassHead kt qType-   classKind = kindOfClass className kt-   argTypeKind = map getType cargs-   subsumptions = zipWith isSubsumedBy classKind argTypeKind-   assocs = [ (tc,as,bs,s) | (tc,as,bs,~(Just s)) <- createInstAssocs kt decls ]-hsInstDeclToInst _ _ = return []---{---- derive statements-hsInstDeclToInst kt (HsDataDecl _sloc _cntxt tyConName argNames _condecls derives@(_:_))-   = return $ map ((,) True) newInstances-   where-   tyConKind = kindOf (toName TypeConstructor tyConName) kt-   flatTyConKind = unfoldKind tyConKind-   argTypeKind = foldr1 Kfun $ drop (length argNames) flatTyConKind-   argsAsTypeList = map (\n -> HsTyVar n) argNames-   typeKindPairs :: [(HsType, Kind)]-   typeKindPairs = (HsTyCon tyConName, tyConKind) : zip argsAsTypeList flatTyConKind-   convertedType :: Type-   convertedType = convType typeKindPairs-   --newContext = map (hsAsstToPred kt) cntxt-   --newInstances = makeDeriveInstances newContext convertedType derives-   newInstances = mempty--hsInstDeclToInst kt (HsNewTypeDecl _sloc _cntxt tyConName argNames _condecls derives@(_:_))-   = return $ map ((,) True) newInstances-   where-   tyConKind = kindOf (toName TypeConstructor tyConName) kt-   flatTyConKind = unfoldKind tyConKind-   argTypeKind = foldr1 Kfun $ drop (length argNames) flatTyConKind-   argsAsTypeList = map (\n -> HsTyVar n) argNames-   typeKindPairs :: [(HsType, Kind)]-   typeKindPairs = (HsTyCon tyConName, tyConKind) : zip argsAsTypeList flatTyConKind-   convertedType :: Type-   convertedType = convType typeKindPairs-   --newContext = map (hsAsstToPred kt) cntxt-   --newInstances = makeDeriveInstances newContext convertedType derives-   newInstances = mempty----- the types will only ever be constructors or vars--convType :: [(HsType, Kind)] -> Type-convType tsks = foldl1 tAp (map toType tsks)--toType :: (HsType, Kind) -> Type-toType (HsTyCon n, k) = TCon $ Tycon (toName TypeConstructor n) k-toType (HsTyVar n, k) = TVar $ tyvar (toName TypeVal n) k-toType (HsTyFun x y, Star) = TArrow (toType (x,Star)) (toType (y,Star))-toType x = error $ "toType: " ++ show x--}---vtrace s v | verbose = trace s v-vtrace s v | otherwise = v---qtToClassHead :: KindEnv -> HsQualType -> ([Pred],(Name,[Type]))-qtToClassHead kt qt@(HsQualType cntx (HsTyApp (HsTyCon className) ty)) =-    vtrace ("qtToClassHead" <+> show qt) $-    let res = (map (hsAsstToPred kt) cntx,-                (toName ClassName className,-                  [runIdentity $ hsTypeToType (kiHsQualType kt (HsQualType cntx (HsTyTuple []))) ty]))-    in vtrace ("=" <+> show res) res---createClassAssocs kt decls = -    [ (ctc n,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)-    ctype HsTyAssoc = Nothing-    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)-    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@(ClassHierarchy classHierarchy) (HsInstDecl sl qualType methods)-    = first concat . unzip . map (methodToTopDecls ch kt [] crecord qualType) $ methodGroups where--    missingMethodNames = map fst methodSigs \\ map getDeclName (filter (not . isHsTypeSig) methods)-    missingMethods-             = [ HsPatBind sl (HsPVar (nameName methodName))-                   (HsUnGuardedRhs -                      (case lookup methodName (classDefaults crecord) of-                         Just name -> HsVar (nameName name)-                         Nothing   -> HsError sl HsErrorSource ("missing method: "++show methodName)))-                   []-                 | methodName <- missingMethodNames-               ]-    methods' = methods ++ missingMethods-    methodGroups = groupEquations methods'-    methodSigs = classAssumps crecord-    (_,(className,_)) = qtToClassHead kt qualType-    crecord = case Map.lookup className classHierarchy  of-        Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"-        Just crecord -> crecord-    tsubst na vv v = applyTyvarMap [(na,vv)] v--instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) (HsClassDecl _ qualType methods)-   = unzip . map (defaultMethodToTopDecls kt methodSigs qualType) $ methodGroups where-   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 $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ "." ++ show t)-defaultInstanceName n = toName Val $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ ".default")---methodToTopDecls ::-    ClassHierarchy-    -> KindEnv         -- ^ the kindenv-    -> [Pred]          -- ^ random extra predicates to add-    -> ClassRecord     -- ^ the class we are lifting methods from-    -> HsQualType-    -> (Name, HsDecl)-    -> ([HsDecl],Assump)--methodToTopDecls _  kt preds crecord qt (methodName, methodDecls)-   = (renamedMethodDecls,(newMethodName, instantiatedSig)) where-    (cntxt,(className,[argType])) = qtToClassHead kt qt-    newMethodName = instanceName methodName (getTypeHead argType)-    sigFromClass = case [ s | (n, s) <- classAssumps crecord, n == methodName] of-        [x] -> x-        _ -> error $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord))-                                      ++ " " ++ show  methodName-    instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType-    renamedMethodDecls = [renameOneDecl newMethodName methodDecls,-                          HsPragmaRules [HsRule {-                                           hsRuleSrcLoc = srcLoc methodDecls,-                                           hsRuleIsMeta = False,-                                           hsRuleIsMethod = True,-                                           hsRuleString = show newMethodName,-                                           hsRuleFreeVars = [],-                                           hsRuleLeftExpr = HsVar (nameName methodName),-                                           hsRuleRightExpr = HsVar (nameName newMethodName)-                                         }]-                         ]-                         --defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsQualType -> (Name, HsDecl) -> (HsDecl,Assump)--defaultMethodToTopDecls kt methodSigs (HsQualType cntxt classApp) (methodName, methodDecls)-   = (renamedMethodDecls,(newMethodName,sigFromClass)) where-    (HsTyApp (HsTyCon className) _) = classApp-    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--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--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------------------------------------------------------------------------------------failSl sl m = fail $ show sl ++ ": " ++ m--classHierarchyFromRecords rs-   = ClassHierarchy $ Map.fromListWith combineClassRecords [  (className x,x)| x <- rs ]---- I love tying el knot.-makeClassHierarchy :: ClassHierarchy -> KindEnv -> [HsDecl] -> ClassHierarchy-makeClassHierarchy (ClassHierarchy ch) kt ds = (ClassHierarchy ans) where-    ans =  Map.fromListWith combineClassRecords [  (className x,x)| x <- execWriter (mapM_ f ds) ]-    f (HsClassDecl sl t decls)-        | HsTyApp (HsTyCon className) (HsTyVar argName)  <- tbody = do-            let qualifiedMethodAssumps-                 = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)-                newClassContext = [HsAsst className [argName]] -- hsContextToContext [(className, argName)]-            tell [ClassRecord { classArgs = classArgs,-                                classAssocs = classAssocs,-                                className = toName ClassName className,-                                classSrcLoc = sl,-                                classSupers = [ toName ClassName x | HsAsst x _ <- cntxt],-                                classInsts = [],-                                classDefaults = [ (methodName, defaultInstanceName methodName)-                                                  | decl <- decls, isHsPatBind decl || isHsFunBind decl,-                                                    let methodName = getDeclName decl-                                                ],-                                classAssumps = qualifiedMethodAssumps }]-        | otherwise = failSl sl "Invalid Class declaration."-        where-        HsQualType cntxt tbody = t-        classAssocs = createClassAssocs kt decls-        (_,(_,classArgs')) = qtToClassHead kt t-        classArgs = [ v | ~(TVar v) <- classArgs' ]-            -    f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do-        crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $-          \ (x,inst) -> case Map.lookup x ch of-            Just cr -> ensureNotDup (srcLoc decl) inst (classInsts cr) >> return [cr { classInsts = mempty }]-            Nothing -> return [] -- case Map.lookup x ans of-                -- Just _ -> return []-               --  Nothing -> return [] -- failSl (srcLoc decl) "Invalid Instance"-        case foldl addOneInstanceToHierarchy (classHierarchyFromRecords (concat crs)) insts of-                ClassHierarchy ch -> tell $ Map.elems ch-    f _ = return ()---ensureNotDup :: Monad m => SrcLoc -> Inst -> [Inst] -> m ()-ensureNotDup sl i is | i `elem` is = failSl sl $ "Duplicate Instance: " ++ show i-                     | otherwise = return ()---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 x = show (pprint x :: Doc)--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-    ]
− src/FrontEnd/DataConsAssump.hs 
@@ -1,102 +0,0 @@-{---------------------------------------------------------------------------------        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.KindInfer-import FrontEnd.Tc.Type-import FrontEnd.HsSyn-import Name.Name-import Support.FreeVars------------------------------------------------------------------------------------dataConsEnv :: Module -> KindEnv -> [HsDecl] -> Map.Map Name Sigma-dataConsEnv modName kt decls-   = Map.unions $ map (dataDeclEnv modName 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 
@@ -1,109 +0,0 @@-{---------------------------------------------------------------------------------        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.HsSyn-import FrontEnd.DependAnalysis(debugBindGroups)-import FrontEnd.Utils(getDeclName)-import FrontEnd.Rename(unRename)-import Name.Name-import FrontEnd.Syn.Traverse-------------------------------------------------------------------------------------- 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 ++ concatMap getLocalDeclDeps wheres-getDeclDeps (HsActionDecl _ _ e) = getExpDeps e-getDeclDeps (HsFunBind matches) = concatMap getMatchDeps matches-getDeclDeps _ = []---getMatchDeps :: HsMatch -> [HsName]-getMatchDeps (HsMatch _sloc _name _pats rhs wheres) = getRhsDeps rhs ++ concatMap getLocalDeclDeps wheres---- get the dependencies from the local definitions in a function--getLocalDeclDeps :: HsDecl -> [HsName]-getLocalDeclDeps (HsFunBind matches) = concatMap getMatchDeps matches--getLocalDeclDeps (HsPatBind _sloc _hspat rhs wheres) = getRhsDeps rhs ++ concatMap 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) = concatMap 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 $ concatMap getLocalDeclDeps decls-expDeps (HsCase e alts) = do-    expDeps e-    tell $ concatMap getAltDeps alts-expDeps (HsDo stmts) = do-    tell $ concatMap getStmtDeps stmts-expDeps (HsListComp e stmts) = do-    expDeps e-    tell $ concatMap getStmtDeps stmts-expDeps e = traverseHsExp_ expDeps e--getAltDeps :: HsAlt -> [HsName]--getAltDeps (HsAlt _sloc _pat guardedAlts wheres)-   = getGuardedAltsDeps guardedAlts ++-     concatMap getLocalDeclDeps wheres--getGuardedAltsDeps :: HsRhs -> [HsName]-getGuardedAltsDeps (HsUnGuardedRhs e) = getExpDeps e--getGuardedAltsDeps (HsGuardedRhss gAlts) = concatMap 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)-   = concatMap getLocalDeclDeps decls
− src/FrontEnd/DependAnalysis.hs 
@@ -1,290 +0,0 @@-{---------------------------------------------------------------------------------        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 List (nub)-import Data.Graph(stronglyConnComp, SCC(..))------------------------------------------------------------------------------------------ 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 
@@ -1,484 +0,0 @@-{---------------------------------------------------------------------------------        Copyright:              The Hatchet Team (see file Contributors)--        Module:                 Desugar--        Description:            Desugaring of the abstract syntax.--                                The main tasks implemented by this module are:-                                        - pattern bindings are converted-                                          into "simple" pattern bindings-                                          (x, y, z) = foo-                                             becomes-                                          newVal = foo-                                          x = (\(a, _, _) -> a) newVal-                                          y = (\(_, a, _) -> a) newVal-                                          z = (\(_, _, a) -> a) newVal-                                        - do notation is converted into-                                          expression form, using (>>) and-                                          (>>=)-                                        - type synonyms are removed--        Primary Authors:        Bernie Pope--        Notes:                  See the file License for license information--                                According to the Haskell report a pattern-                                binding is called "simple" if it consists only-                                of a single variable - thus we convert all-                                pattern bindings to simple bindings.---------------------------------------------------------------------------------}---- Type synonyms are no longer handled here. only 'local' desugaring is done.--- Does this module need to exist?--module FrontEnd.Desugar (doToExp, desugarHsModule, desugarHsStmt) where--import Control.Monad.State--import FrontEnd.SrcLoc-import GenUtil-import FrontEnd.HsSyn-import Name.Name-import Name.Names-import Name.VConsts-import FrontEnd.Syn.Traverse-import FrontEnd.SrcLoc--removeSynonymsFromType _ t = t-removeSynsFromSig _ t = t---- (unique int, list of type synoyms)-type PatState = (Int, [HsDecl])--getUnique = do-    n <- readUnique-    incUnique-    return n--readUnique :: PatSM Int-readUnique = do-        state <- readPatSM-        return (fst state)--readSyns :: PatSM [HsDecl]-readSyns = do-        state <- readPatSM-        return (snd state)---incUnique :: PatSM ()-incUnique = updatePatSM (\(u, s) -> (u + 1, s))--type PatSM = State PatState--instance MonadSrcLoc PatSM where-instance MonadSetSrcLoc PatSM where-    withSrcLoc _ a = a---{------------------------------------------------------------------------------}--readPatSM = get-updatePatSM = modify-runPatSM = flip runState----- a new (unique) name introduced in pattern selector functions-newPatVarName :: HsName-newPatVarName = nameName $ toName Val "patvar@0"---remSynsSig :: HsDecl -> PatSM HsDecl-remSynsSig sig-   = do-        syns <- readSyns-        let newSig = removeSynsFromSig syns sig-        return newSig--remSynsType :: HsType -> PatSM HsType-remSynsType t-   = do-        syns <- readSyns-        let newType = removeSynonymsFromType syns t-        return newType---{-- 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', _) = runPatSM (0::Int, undefined) $ dsm (hsModuleDecls m)-    dsm ds = fmap concat $ mapM desugarDecl ds--desugarHsStmt :: Monad m => HsStmt -> m HsStmt-desugarHsStmt s = return $ fst $ runPatSM (0::Int, undefined) $ desugarStmt s--desugarHsExp :: Monad m => HsExp -> m HsExp-desugarHsExp s = return $ fst $ runPatSM (0::Int, undefined) $ desugarExp s---desugarDecl :: HsDecl -> PatSM [HsDecl]-desugarDecl (HsForeignDecl a b c qt) = do-    qt <- remSynsQualType qt-    return [HsForeignDecl a b c qt]-desugarDecl (HsForeignExport a b c qt) = do-    qt <- remSynsQualType qt-    return [HsForeignExport a b c qt]-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 = nameName $ 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-    newQualType <- remSynsQualType qualtype-    newDecls <- mapM desugarDecl decls-    return [HsInstDecl sloc newQualType (concat newDecls)]--desugarDecl sig@(HsTypeSig _sloc _names _qualType) = do-    newSig <- remSynsSig sig-    return [newSig]---desugarDecl dl@HsDataDecl { hsDeclSrcLoc = sloc, hsDeclName =  name, hsDeclArgs = args, hsDeclCons = condecls, hsDeclDerives = derives } = do-        --newConDecls <- mapM remSynsFromCondecl condecls-        newConDecls <- return condecls-        ds <- deriveInstances sloc name args newConDecls derives-        ss <- createSelectors sloc newConDecls-        return $ dl:(ds ++ ss)--desugarDecl dl@(HsNewTypeDecl sloc cntxt name args condecl derives) = do-        --newConDecl <- remSynsFromCondecl condecl-        newConDecl <- return condecl-        ds <- deriveInstances sloc name args [newConDecl] derives-        ss <- createSelectors sloc [newConDecl]-        return $ dl:(ds ++ ss)--desugarDecl anyOtherDecl = return [anyOtherDecl]----createSelectors _sloc ds = ans where-    ds' :: [(HsName,[(HsName,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 ::  (HsName,[(HsName,HsBangType)]) -> [ (HsName, (HsName,Int,Int)) ]-    f (c,nts) = [ (n,(c,i,length nts)) | (n,_) <- nts | i <- [0..]]-    ans = return $  map g ns-    g (n,cs) = HsFunBind (map f cs ++ [els]) where-        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 } ) []--    var = nameName $ toName Val "x"---deriveInstances :: Monad m => SrcLoc -> HsName -> [HsName] -> [HsConDecl] -> [HsName] -> m [HsDecl]-deriveInstances sloc name args cons ds = return []---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 (HsApp (HsVar (UnQual $ HsIdent "error")) (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 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 _ _) = error  "f name (HsPRec _ _): not implemented"-    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 p = error $ "f: " ++ show (name,p)---desugarRhs :: (HsRhs) -> PatSM (HsRhs)-desugarRhs (HsUnGuardedRhs e)-   = do-        newE <- desugarExp e-        return (HsUnGuardedRhs newE)--desugarRhs (HsGuardedRhss gRhss)-   = do-        newRhss <- mapM desugarGRhs gRhss-        return (HsGuardedRhss newRhss)--desugarGRhs :: HsGuardedRhs -> PatSM (HsGuardedRhs)-desugarGRhs (HsGuardedRhs sloc e1 e2)-   = do-        newE1 <- desugarExp e1-        newE2 <- desugarExp e2-        return (HsGuardedRhs sloc newE1 newE2)----desugarExp :: (HsExp) -> PatSM (HsExp)-desugarExp (HsLambda sloc pats e)-    | all isLazyPat pats && not (any isHsPIrrPat 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) = do-        newStmts <- mapM desugarStmt stmts-        ss <- doToExp newStmts-        return ss-desugarExp (HsListComp e stmts) = do-        newE <- desugarExp e-        newStmts <- mapM desugarStmt stmts-        return (listCompToExp newE newStmts)-desugarExp (HsExpTypeSig sloc e qualType) = do-        e' <- desugarExp e-        newQualType <- remSynsQualType qualType-        return (HsExpTypeSig sloc e' newQualType)-desugarExp e = traverseHsExp desugarExp e----desugarAlt :: (HsAlt) -> PatSM (HsAlt)--desugarAlt (HsAlt sloc pat gAlts wheres) = do-        newGAlts <- desugarGAlts gAlts-        newWheres <- mapM desugarDecl wheres-        return (HsAlt sloc pat newGAlts (concat newWheres))--desugarGAlts :: (HsRhs) -> PatSM (HsRhs)--desugarGAlts (HsUnGuardedRhs e) = do-        newE <- desugarExp e-        return (HsUnGuardedRhs newE)--desugarGAlts (HsGuardedRhss gAlts) = do-        newGAlts <- mapM desugarGuardedAlt gAlts-        return (HsGuardedRhss newGAlts)--desugarGuardedAlt :: (HsGuardedRhs) -> PatSM (HsGuardedRhs)--desugarGuardedAlt (HsGuardedRhs sloc e1 e2) = do-        newE1 <- desugarExp e1-        newE2 <- desugarExp e2-        return (HsGuardedRhs sloc newE1 newE2)--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)---remSynsQualType :: HsQualType -> PatSM HsQualType-remSynsQualType qualtype-   = case qualtype of-        HsQualType cntxt t-           -> do-                 newT <- remSynsType t-                 return (HsQualType cntxt newT)-------------------------------------------------------------------------------------- desugar the do-notation---- flatten out do notation into an expression--- involving ">>" and ">>="--- TODO -  THIS IS BROKEN----f_bind = nameName $ toUnqualified (func_bind sFuncNames)-f_bind_ = nameName $ toUnqualified (func_bind_ sFuncNames)-f_concatMap = nameName $ toUnqualified v_concatMap-f_map = nameName $ toUnqualified v_map-f_foldr = nameName $ toUnqualified v_foldr-f_fail = nameName $ toUnqualified v_fail-f_filter = nameName $ toUnqualified v_filter-f_and = nameName $ toUnqualified v_and-con_cons = nameName $ toUnqualified dc_Cons--doToExp :: Monad m => [HsStmt] -> m HsExp-doToExp [] = fail "doToExp: empty statements in do notation"-doToExp [HsQualifier e] = return e-doToExp [gen@(HsGenerator srcLoc _pat _e)] = fail $ "doToExp: last expression n do notation is a generator (srcLoc):" ++ show srcLoc-doToExp [letst@(HsLetStmt _decls)] = fail $ "doToExp: last expression n do notation is a let statement"-doToExp ((HsQualifier e):ss) = do-    ss <- doToExp ss-    return $ HsInfixApp (hsParen e) (HsVar f_bind_) (hsParen ss)-doToExp ((HsGenerator _srcLoc pat e):ss) | isLazyPat pat = do-    ss <- doToExp ss-    return $ HsInfixApp (hsParen e) (HsVar f_bind) (HsLambda _srcLoc [pat] ss)-doToExp ((HsGenerator srcLoc pat e):ss) = do-    ss <- doToExp ss-    let kase = HsCase patVar [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 newPatVarName] kase)  where-doToExp (HsLetStmt decls:ss) = do-    ss <- doToExp 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-patVar = HsVar newPatVarName--listCompToExp :: HsExp -> [HsStmt] -> HsExp-listCompToExp exp ss = hsParen (f ss) where-    f [] = HsList [exp]-    f (gen:HsQualifier q1:HsQualifier q2:ss)  = f (gen:HsQualifier (hsApp (HsVar f_and) [q1,q2]):ss)-    f ((HsLetStmt ds):ss) = hsParen (HsLet ds (f ss))-    f (HsQualifier e:ss) = hsParen (HsIf e (f ss) (HsList []))-    f ((HsGenerator srcLoc pat e):ss) | isLazyPat pat, Just exp' <- g ss = hsParen $ HsApp (HsApp (HsVar f_map)  (hsParen $ HsLambda srcLoc [pat] exp')) 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 =  hsApp (HsVar f_foldr)  [HsLambda srcLoc [pat,HsPVar newPatVarName] $ hsIf q (hsApp (HsCon con_cons) [exp',patVar]) (HsVar newPatVarName), HsList [],e]-    f ((HsGenerator srcLoc pat e):ss) | isLazyPat pat = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [pat] (f ss))) e-    f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isFailablePat pat || Nothing == (g ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where-        kase = HsCase (HsVar newPatVarName) [a1, a2 ]-        a1 =  HsAlt srcLoc pat (HsGuardedRhss [HsGuardedRhs srcLoc q (f ss)]) []-        a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedRhs $ HsList []) []-    f ((HsGenerator srcLoc pat e):ss) | isFailablePat pat || Nothing == (g ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where-        kase = HsCase (HsVar newPatVarName) [a1, a2 ]-        a1 =  HsAlt srcLoc pat (HsUnGuardedRhs (f ss)) []-        a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedRhs $ HsList []) []-    f ((HsGenerator srcLoc pat e):ss)  = hsParen $ HsApp (HsApp (HsVar f_map)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where-        Just exp' = g ss-        kase = HsCase (HsVar newPatVarName) [a1 ]-        a1 =  HsAlt srcLoc pat (HsUnGuardedRhs exp') []-    g [] = return exp-    g (HsLetStmt ds:ss) = do-        e <- g ss-        return (hsParen (HsLet ds e))-    g _ = Nothing---- patterns are--- failable - may fail to match--- refutable or strict - may bottom out--- irrefutable or lazy - match no matter what--- 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 _ = True-isFailablePat _ = 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 
@@ -1,132 +0,0 @@-{---------------------------------------------------------------------------------        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(..), dumpDiagnostic,-       makeMsg,-       locMsg,-       locSimple,-       simpleMsg,-       typeError,-       TypeError (..),-       ) where--import List  (find)-import Maybe (isJust)-import FrontEnd.SrcLoc-import Data.Monoid------------------------------------------------------------------------------------data TypeError-        = Unification String-        | BogusError-        | 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)-           BogusError    -> ("bogus reason", "bogus reason")-           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 " ++ 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 
@@ -1,142 +0,0 @@---- | determine export\/imports for modules via fixpoint recursion--module FrontEnd.Exports(determineExports,ModInfo(..),modInfoHsModule_s) where--import Data.DeriveTH-import Data.Derive.All-import Control.Monad.Identity-import Data.Monoid-import List-import Maybe-import Prelude hiding (putStr,putStrLn)-import qualified Data.Map as Map-import qualified Data.Set as Set--import CharIO-import Doc.DocLike-import FindFixpoint-import FlagDump as FD-import FrontEnd.SrcLoc-import FrontEnd.HsSyn-import Name.Name as Name-import Options-import Util.Relation as R-import FrontEnd.Warning--data ModInfo = ModInfo {-    modInfoName :: Module,-    modInfoDefs :: [(Name,SrcLoc,[Name])],-    modInfoConsArity :: [(Name,Int)],-    modInfoExport :: [Name],-    modInfoImport :: [(Name,[Name])],-    modInfoHsModule :: HsModule,-    modInfoOptions :: Opt-    }-$(derive makeUpdate ''ModInfo)--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 ((== Module "Prelude") . hsImportDeclModule) xs = xs-        | optPrelude (modInfoOptions m) = (prelude:xs)-        | otherwise = xs-    prelude = HsImportDecl { hsImportDeclSrcLoc = bogusASrcLoc, hsImportDeclModule = Module "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  (map show $ sort (modInfoImport m))-            when (dump FD.Exports) $ do-                putStrLn $ " -- Exports -- " ++  show (modInfoName m)-                putStr $ unlines (map show $ sort (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,Set.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,Set.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 "ambiguous-export" ("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 `R.intersection` qs where-                (qs,unqs) = partitionDomain (isJust . getModule ) is-                g x = Name.qualifyName m x-            f z = entSpec False is z-        return $ mapDomain toUnqualified (R.unions $ map f es)--    -- | 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 . importToExport) xs-                    return $ if isHiding then es Set.\\ listed else listed-            return $ (mapDomain ((Name.qualifyName as)) es' `mappend` if hsImportDeclQualified x then mempty else es')-        is = modInfoModImports mi-        ls = R.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 (HsEVar n) = restrictDomain (== toName Val n) rel-    entSpec isHiding rel (HsEAbs n) = restrictDomain (`elem` [ toName x n | x <- ts]) rel  where-        ts = TypeConstructor:ClassName:if isHiding then [DataConstructor] else []-    entSpec isHiding rel (HsEThingWith n xs) = restrictDomain (\x -> x `elem` concat (ct:(map (cd) xs)))  rel where-        ct = [toName TypeConstructor n, toName ClassName n]-        cd n =  [toName DataConstructor n, toName Val n, toName FieldLabel n ]-    entSpec isHiding rel (HsEThingAll n) = restrictDomain (`elem` ct ) rel `mappend` restrictRange (`elem` ss) rel where-        ct = [toName TypeConstructor n, toName ClassName n]-        ss = concat $ concat [ maybeToList (Map.lookup x ownsMap) | x <- Set.toList $ range (restrictDomain (`elem` ct) rel)]-        cd n =  [toName DataConstructor n, toName Val n, toName FieldLabel n ]---defsToRel xs = R.fromList $ map f xs where-    f (n,_,_) = (toUnqualified n,n)--importToExport :: HsImportSpec -> HsExportSpec-importToExport x = f x where-    f (HsIVar n) = HsEVar n-    f (HsIAbs n) = HsEAbs n-    f (HsIThingAll n) = HsEThingAll n-    f (HsIThingWith n xs) = HsEThingWith n xs-
− src/FrontEnd/FrontEnd.hs 
@@ -1,63 +0,0 @@-module FrontEnd.FrontEnd(-    parseFiles,-    makeLibrary,-    Tc.TiData(..)-    ) where--import Monad-import qualified Data.Map as Map--import Doc.DocLike-import FrontEnd.Exports-import FrontEnd.Rename-import FrontEnd.SrcLoc-import GenUtil-import Ho.Build-import Ho.Collected-import FrontEnd.HsSyn-import Options-import FrontEnd.Warning-import qualified FlagDump as FD-import qualified FrontEnd.Tc.Module as Tc---makeLibrary ifunc func hl = do buildLibrary ifunc (doModules func) hl---- | Main entry point to front end--parseFiles :: [Either Module String]      -- ^ List of files or modules to read-               -> (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial data loaded from ho files-               -> (CollectedHo -> Ho -> Tc.TiData -> IO (CollectedHo,Ho))  -- ^ routine which takes the global ho, the partial local ho and the output of the front end, and returns the completed ho.-               -> IO CollectedHo          -- ^ (the final combined ho,all the loaded ho data)-parseFiles fs ifunc func = do-    wdump FD.Progress $ do-        putErrLn $ "Compiling " ++ show fs-    compileModules fs ifunc (doModules func)---- Process modules found by Ho-doModules :: (CollectedHo -> Ho -> Tc.TiData -> IO (CollectedHo,Ho)) -> CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)-doModules func ho 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 $ hoExp $ choHo ho] (Map.toList $ hoExports $ hoExp $ choHo ho) ms-    (ho',tiData) <- Tc.tiModules' ho ms-    func ho ho' tiData--modInfo m = do-    opt <- case fileOptions (hsModuleOptions m) of-        Just o -> return o-        Nothing -> warn (srcLoc m) "unknown-option" ("Unknown OPTIONS in pragma module" <+> fromModule (hsModuleName m) <+>  show (hsModuleOptions m)) >> return options-    let (xs,ys) = collectDefsHsModule m-    return ModInfo {-        modInfoName = hsModuleName m,-        modInfoDefs = xs,-        modInfoHsModule = m,-        modInfoConsArity = ys,-        modInfoExport = error "modInfoExport",-        modInfoImport = error "modInfoImport",-        modInfoOptions = opt-        }--
− src/FrontEnd/HsErrors.hs 
@@ -1,96 +0,0 @@--- |--- 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.SrcLoc-import FrontEnd.Syn.Traverse-import FrontEnd.HsSyn-import Monad-import Name.Name-import Name.Names-import FrontEnd.Warning-----hsType :: MonadWarn m => HsType -> m ()-hsType x@HsTyForall {} = do-    err "h98-forall" "Explicit quantification is a non-haskell98 feature"-    hsQualType (hsTypeType x)-hsType x@HsTyExists {} = do-    err "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 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) "invalid-decl" $ "complex type arguments not allowed " ++ show context-    f context@(InClass ts) decl@HsTypeDecl { hsDeclTArgs = as }-        | any (not . isHsTyVar) as = warn (srcLoc decl) "invalid-decl" $ "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) "invalid-decl" $ "extra complex type arguments not allowed " ++ show context-    f context decl@HsDataDecl {} = warn (srcLoc decl) "invalid-decl" $ "data declaration not allowed " ++ show context-    f context decl@HsNewTypeDecl {} = warn (srcLoc decl) "invalid-decl" $ "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@HsInstDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InInstance args)) decls-    f context decl@HsClassDecl {} = warn (srcLoc decl) "invalid-decl" $ "class declaration not allowed " ++ show context-    f context decl@HsInstDecl {} = warn (srcLoc decl) "invalid-decl" $ "instance declaration not allowed " ++ show context--    f _ _ = return ()--fetchQtArgs sl HsQualType { hsQualTypeType = t } | (HsTyCon {},args@(_:_)) <- fromHsTypeApp t = return args-fetchQtArgs sl _ = warn sl "invalid-decl" "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 "unknown-deriving" ("attempt to derive from a non-derivable class: " ++ unwords (map show nonDerivable))---fromHsTypeApp t = f t [] where-    f (HsTyApp a b) rs = f a (b:rs)-    f t rs = (t,rs)
− src/FrontEnd/HsParser.y 
@@ -1,970 +0,0 @@-{-# OPTIONS_GHC -w #-} {- -*- 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 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 $$ }-      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 }-      '?'     { Quest }-      '??'    { QuestQuest }-      '*!'    { StarBang }-      '*'     { Star }-      '#'     { Hash }-      '.'     { Dot }---- Reserved Ids--      'as'            { KW_As }-      'derive'        { KW_Derive }-      '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 }--%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 (UnQual (HsIdent "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]) }-      : impdecls ';' topdecls optsemi                 { (reverse $1, fixupHsDecls (reverse $3)) }-      |              topdecls optsemi                 { ([], fixupHsDecls (reverse $1)) }-      | impdecls              optsemi                 { (reverse $1, []) }-      | {- empty -}                                   { ([], []) }--optsemi :: { () }-      : ';'                                           { () }-      | {- 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 ';' 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, [HsImportSpec]) }-      : impspec                               { Just $1 }-      | {- empty -}                           { Nothing }--impspec :: { (Bool, [HsImportSpec]) }-      :  '(' importlist maybecomma ')'        { (False, reverse $2) }-      |  '(' ')'                              { (False, []) }-      |  'hiding' '(' importlist maybecomma ')' { (True,  reverse $3) }--importlist :: { [HsImportSpec] }-      :  importlist ',' import                { $3 : $1 }-      |  import                               { [$1]  }--import :: { HsImportSpec }-      :  var                                  { HsIVar $1 }-      |  tyconorcls                           { HsIAbs $1 }-      |  tyconorcls '(' '..' ')'              { HsIThingAll $1 }-      |  tyconorcls '(' ')'                   { HsIThingWith $1 [] }-      |  tyconorcls '(' cnames ')'            { HsIThingWith $1 (reverse $3) }--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] }-      : topdecls ';' topdecl          { $3 : $1 }-      | topdecl                       { [$1] }--topdecl :: { HsDecl }-      : 'data' ctype srcloc deriving-          {% checkDataHeader $2 `thenP` \(cs,c,t) ->-             returnP hsDataDecl { hsDeclSrcLoc = $3, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $4 } }-      | 'data' ctype '::' kind srcloc deriving-          {% checkDataHeader $2 `thenP` \(cs,c,t) ->-             returnP hsDataDecl { hsDeclSrcLoc = $5, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $6, hsDeclHasKind = Just $4 } }-      | 'data' ctype srcloc '=' constrs deriving-                      {% checkDataHeader $2 `thenP` \(cs,c,t) ->-                         returnP hsDataDecl { hsDeclSrcLoc = $3, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $6, hsDeclCons = reverse $5 } }-      | 'data' 'kind' ctype srcloc '=' constrs deriving-                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->-                         returnP hsDataDecl { hsDeclKindDecl = True, hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6 } }-      | 'newtype' ctype srcloc '=' constr deriving-                      {% checkDataHeader $2 `thenP` \(cs,c,t) ->-                         returnP (HsNewTypeDecl $3 cs c t $5 $6) }-      | 'class' srcloc ctype 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 ctype optvaldefs-                      { HsInstDecl $2 $3 $4 }-      | 'derive' 'instance' srcloc classhead-                      { HsDeclDeriving $3 $4 }-      | 'default' srcloc type-                      { HsDefaultDecl $2 $3 }-      | infixexp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->-                                         returnP (HsActionDecl $2 p $4) }-      | 'foreign' srcloc 'import' varids mstring '::' ctype-                      {% doForeign $2 (UnQual (HsIdent "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 rulelist 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"  } }-      | decl          { $1 }---rule :: { HsRule }-      : srcloc STRING mfreevars exp '=' exp-         { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6-                  , hsRuleIsMeta = error "hsRuleIsMeta not set"-                  , hsRuleIsMethod = False } }--rules :: { [HsRule] }-      : rules optsemi rule  { $3 : $1 }-      | rule optsemi           { [$1] }--rulelist :: { [HsRule] }-      : '{' rules '}' { $2 }-      | layout_on rules close { $2 }--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] }-      : decls1 optsemi                { fixupHsDecls ( reverse $1 ) }-      | optsemi                       { [] }--decls1 :: { [HsDecl] }-      : decls1 ';' 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 }--pragmaprops  :: { HsDecl }-      : PRAGMASTART srcloc  vars PRAGMAEND  { HsPragmaProps $2 $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 }-       |  '*!'                  { 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 { HsTyExpKind { hsTySrcLoc = $1, hsTyType = $2, hsTyKind = $4 } }-    | type                  { $1 }--gtycon :: { HsName }-      : qconid                        { $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 }-      : btype '=>' type               {% checkContext $1 `thenP` \c ->-                                         returnP (HsQualType c $3) }-      | type                          { HsQualType [] $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 } }--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]) }-      | scontype1 satype              { (fst $1, snd $1 ++ [$2] ) }--satype :: { HsBangType }-      : atype                         { HsUnBangedTy $1 }-      | '!' atype                     { HsBangedTy   $2 }--sbtype :: { HsBangType }-      : btype                         { HsUnBangedTy $1 }-      | '!' 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 }--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 }-      | 'type' simpletype srcloc-                      { HsTypeDecl $3 (fst $2) (snd $2) HsTyAssoc }-      | infixexp srcloc rhs                   {% checkValDef $2 $1 $3 []}-      | infixexp srcloc rhs 'where' decllist  {% checkValDef $2 $1 $3 $5}--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 }--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] }---- -------------------------------------------------------------------------------- List comprehensions--quals :: { [HsStmt] }-      : quals ',' qual                        { $3 : $1 }-      | qual                                  { [$1] }--qual  :: { HsStmt }-      : infixexp 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 }-      : infixexp srcloc ralt  {% checkPattern $1 `thenP` \p ->-                                 returnP (HsAlt $2 p $3 []) }-      | infixexp srcloc ralt 'where' decllist-                              {% checkPattern $1 `thenP` \p ->-                                 returnP (HsAlt $2 p $3 $5) }--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] }-      : stmts1 ';' exp                { reverse (HsQualifier $3 : $1) }-      | exp                           { [HsQualifier $1] }--stmts1 :: { [HsStmt] }-      : stmts1 ';' qual               { $3 : $1 }-      | qual                          { [$1] }---- -------------------------------------------------------------------------------- Record Field Update/Construction--fbinds :: { [HsFieldUpdate] }-      : fbinds ',' fbind              { $3 : $1 }-      | fbind                         { [$1] }--fbind :: { HsFieldUpdate }-      : qvar '=' exp                  { 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                { Qual (Module (fst $1)) (HsIdent (snd $1)) }--varid :: { HsName }-      : VARID                 { UnQual (HsIdent $1) }-      | 'as'                  { as_name }-      | 'alias'               { UnQual (HsIdent "alias") }-      | 'kind'                { UnQual (HsIdent "kind") }-      | 'qualified'           { qualified_name }-      | 'hiding'              { hiding_name }-      | 'forall'              { UnQual (HsIdent "forall") }-      | 'exists'              { UnQual (HsIdent "exists") }-      | 'derive'              { derive_name }--qconid :: { HsName }-      : conid                 {  $1 }-      | QCONID                { Qual (Module (fst $1)) (HsIdent (snd $1)) }--conid :: { HsName }-      : CONID                 { UnQual (HsIdent $1) }--qconsym :: { HsName }-      : consym                {  $1 }-      | QCONSYM               { Qual (Module (fst $1)) (hsSymbol (snd $1)) }--consym :: { HsName }-      : CONSYM                { UnQual (hsSymbol $1) }--qvarsym :: { HsName }-      : varsym                { $1 }-      | qvarsym1              { $1 }--qvarsymm :: { HsName }-      : varsymm               { $1 }-      | qvarsym1              { $1 }--varsym :: { HsName }-      : VARSYM                { UnQual (hsSymbol $1) }-      | '-'                   { minus_name }-      | '!'                   { pling_name }-      | '?'                   { UnQual (hsSymbol "?") }-      | '??'                  { UnQual (hsSymbol "??") }-      | '*!'                  { UnQual (hsSymbol "*!") }-      | '*'                   { star_name }-      | '#'                   { hash_name }-      | '.'                   { dot_name }--varsymm :: { HsName } -- varsym not including '-'-      : VARSYM                { UnQual (hsSymbol $1) }-      | '!'                   { pling_name }-      | '*'                   { star_name }-      | '#'                   { hash_name }-      | '.'                   { dot_name }--qvarsym1 :: { HsName }-      : QVARSYM               { Qual (Module (fst $1)) (hsSymbol (snd $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  :: { () }  : optsemi  {% getSrcLoc `thenP` \sl ->-                                 pushCurrentContext  }----                                 pushCurrentContext (Layout (srcLocColumn sl)) }---- -------------------------------------------------------------------------------- Miscellaneous (mostly renamings)--modid :: { Module }-      : CONID                 { Module $1 }-      | QCONID                { Module (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 #-}--happyError = parseError "Parse error"-hsSymbol x = HsIdent x-readInteger x = fromIntegral x-readRational x = x--as_name	              = UnQual $ HsIdent "as"-derive_name	      = UnQual $ HsIdent "derive"-qualified_name        = UnQual $ HsIdent "qualified"-hiding_name	      = UnQual $ HsIdent "hiding"-minus_name	      = UnQual $ HsIdent "-"-pling_name	      = UnQual $ HsIdent "!"-star_name	      = UnQual $ HsIdent "*"-hash_name	      = UnQual $ HsIdent "#"-dot_name	      = UnQual $ HsIdent "."-prelude_mod	      = Module "Prelude"-main_mod	      = Module "Main"--unit_con_name	      = UnQual (HsIdent "()")-tuple_con_name i      = Qual (Module "Lhc.Basics") (HsIdent ("("++replicate i ','++")"))--unit_con	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = unit_con_name }-tuple_con i	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = (tuple_con_name i) }---unit_tycon_name       = unit_con_name-fun_tycon_name        = Qual (Module "Lhc.Basics") (HsIdent "->")-list_tycon_name       = UnQual (HsIdent "[]")-tuple_tycon_name i    = tuple_con_name i--list_tycon	      = HsTyCon list_tycon_name-}
− src/FrontEnd/HsPretty.hs 
@@ -1,717 +0,0 @@---------------------------------------------------------------------------------  $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 Char-import qualified Text.PrettyPrint.ANSI.Leijen as P--import Doc.PPrint(pprint)-import FlagDump as FD-import FrontEnd.Rename(unRename)-import FrontEnd.SrcLoc(Located(..))-import FrontEnd.HsSyn-import Name.Names-import Name.Name-import Options-import Doc.DocLike(TextLike(..),DocLike(..))-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 <> b)}-    aM <+> bM = do{a<-aM;b<-bM;return (a <+> b)}-    aM <$> bM = do{a<-aM;b<-bM;return (a <$> b)}-    hcat dl = sequence dl >>= return . hcat-    hsep dl = sequence dl >>= return . hsep-    vcat dl = sequence dl >>= return . vcat--($$) :: Doc -> Doc -> Doc-aM $$ bM = do{a<-aM;b<-bM;return (a <$> b)}---fsep :: [Doc] -> Doc-fsep dl = sequence dl >>= return . P.fillSep----- 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 = show . 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 modName,-		 maybePP (parenList . map ppHsExportSpec) mbExportList,-		 text "where"]--ppHsExportSpec :: HsExportSpec -> Doc-ppHsExportSpec (HsEVar name)                     = ppHsQNameParen name-ppHsExportSpec (HsEAbs name)                     = ppHsQName name-ppHsExportSpec (HsEThingAll name)                = ppHsQName name <> text"(..)"-ppHsExportSpec (HsEThingWith name nameList)      = ppHsQName name <>-                                                   (parenList . map ppHsQNameParen $ nameList)-ppHsExportSpec (HsEModuleContents (Module name)) = text "module" <+> text name--ppHsImportDecl (HsImportDecl pos (Module mod) bool mbName mbSpecs) =-	   mySep [text "import",-		 if bool then text "qualified" else empty,-		 text mod,-		 maybePP (\(Module n) -> text "as" <+> text n) mbName,-		 maybePP exports mbSpecs]-           where-	   exports (b,specList)-	    | b = text "hiding" <+> (parenList . map ppHsImportSpec $ specList)-	    | otherwise = parenList . map ppHsImportSpec $  specList--ppHsImportSpec :: HsImportSpec -> Doc-ppHsImportSpec (HsIVar name)                     = ppHsNameParen name-ppHsImportSpec (HsIAbs name)                     = ppHsName name-ppHsImportSpec (HsIThingAll name)                = ppHsName name <> text"(..)"-ppHsImportSpec (HsIThingWith name nameList)      = ppHsName name <>-                                                   (parenList . map ppHsNameParen $ nameList)-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 { hsDeclContext = context, hsDeclName = name, hsDeclArgs = nameList, hsDeclCons = constrList, hsDeclDerives = derives } =-	   --blankline $-           mySep ([text "data", ppHsContext context, ppHsName name]-                  ++ map ppHsName nameList)-                  <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))-                                           (map ppHsConstr constrList))-                       $$$ ppHsDeriving derives)--ppHsDecl (HsNewTypeDecl pos context name nameList constr derives) =-	   --blankline $-           mySep ([text "newtype", ppHsContext context, ppHsName name]-                  ++ map ppHsName nameList)-                  <+> equals <+> (ppHsConstr constr-                                  $$$ ppHsDeriving derives)---m{spacing=False}--- special case for empty class declaration-ppHsDecl (HsClassDecl pos qualType []) =-	   --blankline $-	   mySep [text "class", ppHsQualType qualType]-ppHsDecl (HsClassDecl pos qualType declList) =-	   --blankline $-	   mySep [text "class", ppHsQualType 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", ppHsQualType qualType]-ppHsDecl (HsInstDecl pos qualType declList) =-	   --blankline $-	   mySep [text "instance", ppHsQualType 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 "#-}"--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--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 { hsTyType = t, hsTyKind = k } = do-    t <- ppHsType t-    return $ DL.parens ( t DL.<+> DL.text "::" DL.<+> pprint k)--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--- 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]--------------------------- 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--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 (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:_) <- hsIdentString (hsNameIdent (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/HsSyn.hs 
@@ -1,446 +0,0 @@-module FrontEnd.HsSyn where--import Data.DeriveTH-import Data.Derive.All-import StringTable.Atom-import StringTable.Atom()-import Data.Binary-import C.FFI-import Data.Generics-import FrontEnd.SrcLoc-import Control.Monad-----newtype Module = Module String-  deriving(Eq,Data,Typeable,Ord,ToAtom,FromAtom)--instance Show Module where-    showsPrec _ (Module n) = showString n--fromModule (Module s) = s---- Names-newtype HsIdentifier = HsIdent { hsIdentString :: String }-  deriving(Data,Typeable,Eq,Ord)---data HsName-	= Qual { hsNameModule :: Module, hsNameIdent ::  HsIdentifier}-	| UnQual { hsNameIdent :: HsIdentifier}-  deriving(Data,Typeable,Eq,Ord)--instance ToAtom HsName where-    toAtom = toAtom . show--instance Show HsName where-   showsPrec _ (Qual (Module m) s) =-	showString m . showString "." . shows s-   showsPrec _ (UnQual s) = shows s--instance Binary Module where-    get = do-        ps <- get-        return (Module $ fromAtom ps)-    put (Module n) = put (toAtom n)--instance Binary HsIdentifier where-    get = do-        ps <- get-        return (HsIdent $ fromAtom ps)-    put (HsIdent n) = put (toAtom n)--hsIdentString_u f x = x { hsIdentString = f $ hsIdentString x }----	| HsSymbol {hsIdentString :: String }---	| HsSpecial {hsIdentString :: String }--instance Show HsIdentifier where-   showsPrec _ (HsIdent s) = showString s---   showsPrec _ (HsSymbol s) = showString s---   showsPrec _ (HsSpecial s) = showString s---- 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)-  deriving(Eq,Show)--instance HasLocation HsImportDecl where-    srcLoc x = hsImportDeclSrcLoc x--data HsKind = HsKind HsName | HsKindFn HsKind HsKind-  deriving(Data,Typeable,Eq,Ord,Show)--hsKindStar = HsKind (Qual (Module "Lhc@") (HsIdent "*"))-hsKindHash = HsKind (Qual (Module "Lhc@") (HsIdent "#"))-hsKindBang = HsKind (Qual (Module "Lhc@") (HsIdent "!"))-hsKindQuest = HsKind (Qual (Module "Lhc@") (HsIdent "?"))-hsKindQuestQuest = HsKind (Qual (Module "Lhc@") (HsIdent "??"))-hsKindStarBang   = HsKind (Qual (Module "Lhc@") (HsIdent "*!"))----data HsImportSpec-	 = HsIVar HsName		-- variable-	 | HsIAbs HsName		-- T-	 | HsIThingAll HsName		-- T(..)-	 | HsIThingWith HsName [HsName]	-- T(C_1,...,C_n)-  deriving(Eq,Show)--data HsImportDecl = HsImportDecl {-    hsImportDeclSrcLoc :: SrcLoc,-    hsImportDeclModule :: Module,-    hsImportDeclQualified :: !Bool,-    hsImportDeclAs :: (Maybe Module),-    hsImportDeclSpec :: (Maybe (Bool,[HsImportSpec]))-    }-  deriving(Eq,Show)--data HsAssoc = HsAssocNone | HsAssocLeft | HsAssocRight-  deriving(Eq,Show)-$(derive makeBinary ''HsAssoc)--data HsAsst = HsAsst HsName [HsName] | HsAsstEq HsType HsType-  deriving(Data,Typeable,Eq,Ord, Show)--type HsContext = [HsAsst]--data HsQualType-	 = HsQualType   { hsQualTypeContext :: HsContext, hsQualTypeType :: HsType }-  deriving(Data,Typeable,Eq,Ord,Show)--data HsTyVarBind = HsTyVarBind {-    hsTyVarBindSrcLoc :: SrcLoc,-    hsTyVarBindName :: HsName,-    hsTyVarBindKind :: Maybe HsKind }-  deriving(Data,Typeable,Eq,Ord,Show)--hsTyVarBind = HsTyVarBind { hsTyVarBindSrcLoc = bogusASrcLoc, hsTyVarBindName = undefined, hsTyVarBindKind = Nothing }--instance HasLocation HsTyVarBind where-    srcLoc = hsTyVarBindSrcLoc--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 { hsTySrcLoc :: SrcLoc, hsTyType :: HsType, hsTyKind :: HsKind }-         -- the following are used internally-         | HsTyAssoc-         | HsTyEq HsType HsType-  deriving(Data,Typeable,Eq,Ord,Show)--data HsDecl-    = HsTypeDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclName :: HsName, hsDeclTArgs :: [HsType], hsDeclType :: HsType }-    | HsDataDecl	 {-        hsDeclKindDecl :: Bool,-        hsDeclSrcLoc :: SrcLoc,-        hsDeclContext :: HsContext,-        hsDeclName :: HsName,-        hsDeclArgs :: [HsName],-        hsDeclCons :: [HsConDecl],-        hsDeclHasKind :: Maybe HsKind,-        {- deriving -} hsDeclDerives :: [HsName]-        }-    | HsNewTypeDecl {-        hsDeclSrcLoc :: SrcLoc,-        hsDeclContext :: HsContext,-        hsDeclName :: HsName,-        hsDeclArgs :: [HsName],-        hsDeclCon :: HsConDecl,-        {- deriving -} hsDeclDerives :: [HsName]-        }-    | HsInfixDecl   { hsDeclSrcLoc :: SrcLoc, hsDeclAssoc :: HsAssoc, hsDeclInt :: !Int, hsDeclNames :: [HsName]  }-    | HsClassDecl   { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType, hsDeclDecls :: [HsDecl] }-    | HsClassAliasDecl {-        hsDeclSrcLoc :: SrcLoc,-        hsDeclName :: HsName,-        hsDeclTypeArgs :: [HsType],-        {- rhs -} hsDeclContext :: HsContext,-                  hsDeclClasses :: HsContext,-        hsDeclDecls :: [HsDecl]-        }-    | HsInstDecl    { hsDeclSrcLoc :: SrcLoc, hsDeclQualType :: HsQualType, 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)--instance HasLocation HsDecl where-    srcLoc HsTypeDecl	  { hsDeclSrcLoc  = sl } = sl-    srcLoc HsDeclDeriving { hsDeclSrcLoc  = sl } = sl-    srcLoc HsSpaceDecl    { hsDeclSrcLoc  = sl } = sl-    srcLoc HsDataDecl	  { hsDeclSrcLoc  = sl } = sl-    srcLoc HsInfixDecl    { hsDeclSrcLoc = sl } = sl-    srcLoc HsNewTypeDecl  { 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--hsDataDecl = HsDataDecl {-    hsDeclKindDecl = False,-    hsDeclSrcLoc = bogusASrcLoc,-    hsDeclContext = [],-    hsDeclName = error "hsDataDecl.hsDeclName",-    hsDeclArgs = [],-    hsDeclCons = [],-    hsDeclHasKind = Nothing,-    hsDeclDerives = []-    }--hsNewTypeDecl = HsNewTypeDecl {-    hsDeclSrcLoc = bogusASrcLoc,-    hsDeclContext = [],-    hsDeclName = error "hsNewTypeDecl.hsDeclName",-    hsDeclArgs = [],-    hsDeclCon = error "hsNewTypeDecl.hsDeclCon",-    hsDeclDerives = []-    }--data HsModule = HsModule {-    hsModuleName :: Module,-    hsModuleSrcLoc :: SrcLoc,-    hsModuleExports :: (Maybe [HsExportSpec]),-    hsModuleImports :: [HsImportDecl],-    hsModuleDecls :: [HsDecl],-    hsModuleOptions :: [String]-    }--instance HasLocation HsModule where-    srcLoc x = hsModuleSrcLoc x--data HsRule = HsRule {-    hsRuleSrcLoc :: SrcLoc,-    hsRuleIsMeta :: Bool,-    hsRuleIsMethod :: Bool, -- for rules generated by FrontEnd.Class-    hsRuleString :: String,-    hsRuleFreeVars :: [(HsName,Maybe HsType)],-    hsRuleLeftExpr :: HsExp,-    hsRuleRightExpr :: HsExp-    }-  deriving(Eq,Show)--instance HasLocation HsRule where-    srcLoc HsRule { hsRuleSrcLoc = sl } = sl--instance HasLocation HsMatch where-    srcLoc (HsMatch sl _ _ _ _) = sl--data HsMatch-	 = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [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)--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)--hsQualTypeHsContext HsQualType { hsQualTypeContext = c } = c----type HsAsst    = (HsName,[HsType])	-- for multi-parameter type classes---type HsAsst    = (HsName,HsName)	-- clobber--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)---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 }  -- pattern only-        | HsError { hsExpSrcLoc :: SrcLoc, hsExpErrorType :: HsErrorType, hsExpString :: String }-	| HsWildCard SrcLoc			-- ditto-	| HsIrrPat { hsExpLExp :: LHsExp }- deriving(Eq,Show)--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--data HsClassHead = HsClassHead { hsClassHeadContext :: HsContext, hsClassHead :: HsName, hsClassHeadArgs :: [HsType] }- deriving(Eq,Show)--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 }-	| HsPTypeSig SrcLoc HsPat HsQualType  -- scoped type variable extension- deriving(Eq,Ord,Show)--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)---------------------------------------------------------------------------------- Deriving stuff--$(derive makeIs ''HsName)-$(derive makeUpdate ''HsName)-$(derive makeBinary ''HsName)-$(derive makeBinary ''HsKind)-$(derive makeIs ''HsType)-$(derive makeBinary ''HsType)-$(derive makeBinary ''HsAsst)-$(derive makeBinary ''HsQualType)-$(derive makeBinary ''HsTyVarBind)-$(derive makeUpdate ''HsTyVarBind)-$(derive makeIs ''HsDecl)-$(derive makeUpdate ''HsModule)-$(derive makeIs ''HsConDecl)-$(derive makeUpdate ''HsConDecl)-$(derive makeIs ''HsLiteral)-$(derive makeUpdate ''HsExp)-$(derive makeIs ''HsExp)-$(derive makeUpdate ''HsClassHead)-$(derive makeIs ''HsPat)
− src/FrontEnd/Infix.hs 
@@ -1,328 +0,0 @@-{---------------------------------------------------------------------------------        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 Util.HasSize-import FrontEnd.HsSyn-import Name.Name--------------------------------------------------------------------------------type FixityInfo = (Int, HsAssoc)-type SymbolMap = Map.Map Name FixityInfo--newtype FixityMap = FixityMap SymbolMap-    deriving(Monoid,HasSize)--instance Binary FixityMap where-    put (FixityMap ts) = put ts-    get = fmap FixityMap get--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)-    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)-    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/KindInfer.hs 
@@ -1,554 +0,0 @@---- |--- 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 Data.DeriveTH-import Data.Derive.All-import Control.Monad.Reader-import Data.List-import qualified Data.Traversable as T-import Util.Inst()-import Data.Maybe-import Control.Monad.Identity-import Control.Monad.Writer-import Data.Generics-import Data.IORef-import Data.Monoid-import qualified Data.Map as Map-import System.IO.Unsafe--import Data.Binary-import Doc.DocLike-import Doc.PPrint-import FrontEnd.Tc.Type-import FrontEnd.Tc.Kind-import FrontEnd.Utils-import GenUtil-import Support.FreeVars-import FrontEnd.HsSyn-import Name.Name-import qualified Util.Seq as Seq-import qualified FlagDump as FD-import Options-import Util.ContextMonad-import Util.HasSize---data KindEnv = KindEnv {-    kindEnv :: Map.Map Name Kind,-    kindEnvAssocs :: Map.Map Name (Int,Int),-    kindEnvClasses :: Map.Map Name [Kind]-    } deriving(Typeable,Show)-$(derive makeMonoid ''KindEnv)--instance Binary KindEnv where-    put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } = put a >> put b >> put c-    get = do-        a <- get-        b <- get-        c <- get-        return KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c }--instance HasSize KindEnv where-    size KindEnv { kindEnv = env } = size env--instance FreeVars Kind [Kindvar] where-   freeVars (KVar kindvar) = [kindvar]-   freeVars (kind1 `Kfun` kind2) = freeVars kind1 `union` freeVars kind2-   freeVars KBase {} = []----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 {-    kiContext :: [String],-    kiEnv :: IORef KindEnv,-    kiWhere :: KiWhere,-    kiVarnum :: IORef Int-    }--newtype Ki a = Ki (ReaderT KiEnv IO a)-    deriving(Monad,MonadReader KiEnv,MonadIO,Functor)---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 { kiContext = [], kiEnv = env, kiVarnum = varnum, kiWhere = Other }-    ki' e = runReaderT ki e---instance ContextMonad String Ki where-    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 = fail $ "attempt to unify these two kinds: " ++ show k1 ++ " <-> " ++ 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 `elem` freeVars k) $ fail $ "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 <- findKind k-            constrain con k-            findKind k-        Nothing -> do-            kv <- newKindVar con-            extendEnv mempty { kindEnv = Map.singleton name (KVar kv) }-            return (KVar kv)--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 ()--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 = snub (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 { hsTyType = 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--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--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--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 (toName ClassName n) (kindEnvClasses env) of-        Nothing -> fail $ "unknown class: " ++ show asst-        Just ks -> zipWithM_ f ks ns-kiPred (HsAsstEq a b) = do-    mv <- newKindVar KindSimple-    kiType  (KVar mv) a-    kiType' (KVar mv) b--kiInitClasses :: [HsDecl] -> Ki ()-kiInitClasses ds =  sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds]-                    >> sequence_ [ f (hsDeclName cad) [v | HsTyVar v <- hsDeclTypeArgs cad]-                                   | cad@(HsClassAliasDecl {}) <- ds ]-    where-    f className args = do-        args <- mapM (lookupKind KindSimple . toName TypeVal) args-        extendEnv mempty { kindEnvClasses = Map.singleton (toName ClassName className) args }---kiDecl :: HsDecl -> Ki ()-kiDecl 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-kiDecl HsDataDecl { hsDeclContext = context, hsDeclName = tyconName, hsDeclArgs = args, hsDeclCons = condecls } = kiData context tyconName args condecls-kiDecl HsNewTypeDecl { hsDeclContext = context, hsDeclName = tyconName, hsDeclArgs = args, hsDeclCon = condecl } = kiData context tyconName args [condecl]-kiDecl 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-kiDecl (HsTypeSig _ _ (HsQualType ps t)) = do-    mapM_ kiPred ps-    kiType kindStar t-kiDecl (HsClassDecl _sloc qualType sigsAndDefaults) = ans where-    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-kiDecl _ = return ()--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--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)-        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 { hsTyType = 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 (hsIdentString . hsNameIdent $ 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)----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 = hsQualTypeHsContext 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 :=> t))-        | (TForAll vs' (ps' :=> t')) <- nt = f $ TForAll (vs ++ vs') ((ps ++ ps') :=> t')-        | otherwise = TForAll vs (ps :=> nt)-        where-        nt = f t-    f (TExists vs (ps :=> t))-        | (TExists vs' (ps' :=> t')) <- nt = f $ TExists (vs ++ vs') ((ps ++ ps') :=> t')-        | otherwise = TExists vs (ps :=> nt)-        where-        nt = f t-    f (TArrow a b)-        | 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-        where-        na = f a-        nb = f b-
− src/FrontEnd/Lexer.hs 
@@ -1,680 +0,0 @@--- #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 Char-import Data.Ratio-import qualified Data.Map as Map--import FrontEnd.ParseMonad-import FrontEnd.Warning-import FrontEnd.SrcLoc--data Token-        = VarId String-        | QVarId (String,String)-	| ConId String-        | QConId (String,String)-        | VarSym String-        | ConSym String-        | QVarSym (String,String)-        | QConSym (String,String)-	| IntTok  Integer-	| UIntTok Integer-	| FloatTok Rational-	| Character Char-	| UCharacter Char-        | StringTok String-        | UStringTok String-        | PragmaOptions [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-	| Star-	| Hash-	| Dot---- Reserved Ids--	| KW_As-	| KW_Case-	| KW_Class-        | KW_Alias-	| KW_Data-	| KW_Default-	| KW_Deriving-	| KW_Derive-	| 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--        | EOF-        deriving (Eq,Show)--reserved_ops :: [(String,Token)]-reserved_ops = [- ( "..", 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 :: [(String,Token)]-special_varops = [- ( "-",  Minus ),	--ToDo: shouldn't be here- ( "?",  Quest ),     --ditto- ( "??", QuestQuest ),--ditto- ( "*!", StarBang ),--ditto- ( "!",  Exclamation ),	--ditto- ( ".",  Dot ),		--ditto- ( "*",  Star ),	--ditto- ( "#",  Hash )		--ditto- ]--reserved_ids :: [(String,Token)]-reserved_ids = [- ( "_",         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 ),- ( "foreign",   KW_Foreign ),- ( "forall",    KW_Forall ),- ( "exists",    KW_Exists ),- ( "where", 	KW_Where )- ]--special_varids :: [(String,Token)]-special_varids = [- ( "as", 	KW_As ),- ( "kind", 	KW_Kind ),- ( "qualified", KW_Qualified ),- ( "derive",    KW_Derive ),- ( "hiding", 	KW_Hiding )- ]--isIdent, isSymbol :: Char -> Bool-isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'-isSymbol c = elem 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 $ 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-            setFilePos (fromInteger v - 1) 1 fn-            lexWhiteSpace False-    s <- getInput-    case s of-        '{':'-':'#':s-            | pname `Map.member` pragmas -> return bol-            | otherwise -> do-                addWarn "unknown-pragma" $ "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"-                _ -> do-                    lexNewline-                    lexWhiteSpace True-        '\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 = 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, parseFFI = doFFI } <- lexParseMode-    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 == '_' -> do-		ident <- lexWhile isIdent-		return $ case lookup ident (reserved_ids ++ special_varids) of-                        Just KW_Foreign-                            | doFFI -> KW_Foreign-                            | otherwise -> VarId ident-			Just keyword -> keyword-			Nothing -> VarId ident--	    | isSymbol c -> do-		sym <- lexWhile isSymbol-		return $ case lookup sym (reserved_ops ++ special_varops) of-			Just t  -> t-			Nothing -> case c of-			    ':' -> ConSym sym-			    _   -> VarSym sym--	    | 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)-                                _ -> 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':_ -> 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 con-		  | otherwise = QConId (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 lookup ident reserved_ids of-		   -- cannot qualify a reserved word-		   Just _  -> just_a_conid-		   Nothing -> return (QVarId (qual', ident))--	     | isUpper c -> do		-- qualified conid?-		discard 1-		lexConIdOrQual qual'--	     | isSymbol c -> do	-- qualified symbol?-		discard 1-		sym <- lexWhile isSymbol-		case lookup sym reserved_ops of-		    -- cannot qualify a reserved operator-		    Just _  -> just_a_conid-		    Nothing -> return $ case c of-			':' -> QConSym (qual', sym)-			_   -> QVarSym (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", "LHC_OPTIONS", "OPTIONS_LHC" ]]---- pragmas which just have a simple string based start rule.-pragmas_std = [-    ["INLINE"],-    ["NOETA"],-    ["SUPERINLINE"],-    ["NOINLINE","NOTINLINE"],-    ["MULTISPECIALIZE", "MULTISPECIALISE"],-    ["SRCLOC_ANNOTATE"]-    ]---- pragmas with a special starting token-pragmas_parsed = [-    (["RULES","RULE","RULES_LHC","RULE_LHC"],PragmaRules False),-    (["CATALYST","CATALYSTS"],PragmaRules True),-    (["SPECIALIZE", "SPECIALISE"],PragmaSpecialize False),-    (["SUPERSPECIALIZE", "SUPERSPECIALISE"],PragmaSpecialize True)-    ]--pragmas_all = pragmas_parsed ++ [ (xs,PragmaStart x) | xs@(~(x:_)) <- pragmas_std ]--pragmas = Map.fromList $ [ (y,Left x) | xs@(x:_)  <- pragmas_raw, y <- xs] ++  [ (y,Right w) | (xs@(~(x:_)),w)  <- pragmas_all , y <- xs]--normPragma :: String -> Either String Token-normPragma s | ~(Just v) <- Map.lookup s pragmas  = v--
− src/FrontEnd/ParseMonad.hs 
@@ -1,313 +0,0 @@--- #hide--------------------------------------------------------------------------------- |--- 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-	) where--import qualified Data.Set as Set--import FrontEnd.SrcLoc-import FrontEnd.Warning-import Options-import qualified FlagOpts as FO---- | The result of a parse.-data ParseResult a-	= ParseOk [Warning] 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] }-    deriving(Show)--indentOfParseState :: ParseState -> Int-indentOfParseState ParseState { psLexContext = (Layout n:_) } = n-indentOfParseState _            = 0--emptyParseState = ParseState { psLexContext = [], psWarnings = [] }---- | 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      :: String,-                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>",-                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-    }---- | 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 -> ParseResult a-runParserWithMode mode (P m) s = case m s 0 1 start emptyParseState mode of-	Ok s a -> ParseOk (psWarnings s) a-	Failed loc msg -> ParseFailed loc msg-    where start = SrcLoc {-		srcLocFileName = parseFilename mode,-		srcLocLine = 1,-		srcLocColumn = 1-	}--runParser :: P a -> String -> 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-	loc <- getSrcLoc-	indent <- currentIndent-	pushContext (Layout (max (indent) (srcLocColumn 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"---- 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 
@@ -1,473 +0,0 @@--- #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 (HsName,[HsType])-	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp-	, checkPrec		-- Integer -> P Int-	, checkContext		-- HsType -> P HsContext-	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])-	, checkPattern		-- HsExp -> P HsPat-	, checkPatterns-	, checkExpr		-- HsExp -> P HsExp-	, checkValDef		-- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl-	, checkUnQual		-- HsQName -> P HsName-        , readInteger-        , readRational-        , fixupHsDecls-        , parseError-        , parseExport-        , qualTypeToClassHead-        , doForeign-        , doForeignEq- ) where--import Char-import Data.Monoid-import Ratio-import qualified Data.Traversable as T--import C.FFI-import FrontEnd.ParseMonad-import FrontEnd.SrcLoc-import FrontEnd.HsSyn--type HsQName = HsName--parseError :: String -> P a-parseError = fail--splitTyConApp :: HsType -> P (HsName,[HsType])-splitTyConApp t0 = split t0 []- where-	split :: HsType -> [HsType] -> P (HsName,[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 (UnQual (HsIdent "()"))) = 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,HsName,[HsName])-checkDataHeader (HsQualType cs t) = do-	(c,ts) <- checkSimple "data/newtype" t []-	return (cs,c,ts)--checkClassHeader :: HsQualType -> P (HsContext,HsName,[HsName])-checkClassHeader (HsQualType cs t) = do-	(c,ts) <- checkSimple "class" t []-	return (cs,c,ts)--checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName]))-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,HsQName,[HsType])-checkInstHeader (HsQualType cs t) = do-	(c,ts) <- checkInsts t []-	return (cs,c,ts)--checkInsts :: HsType -> [HsType] -> P ((HsQName,[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)-	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 (HsName, [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 :: HsQName -> P HsName-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 :: HsName -> HsDecl -> Bool-sameFun name (HsFunBind matches@(_:_)) = name == (matchName $ head matches)-sameFun _ _ = False--doForeign :: Monad m => SrcLoc -> [HsName] -> Maybe (String,HsName) -> HsQualType -> m HsDecl-doForeign srcLoc names ms qt = ans where-    ans = do-        (mstring,vname@(UnQual (HsIdent 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 mstring vname-                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) vname qt-        f (map show names') (maybe cname id mstring) where-    pconv rs = case rs of-                ("safe":rs) -> g Safe rs-                ("unsafe":rs) -> g Unsafe rs-                rs -> g Safe rs-            where-            g safe [] = (safe,CCall)-            g safe ["ccall"] = (safe,CCall)-            g safe ["stdcall"] = (safe,StdCall)-            g x y = error $ "FrontEnd.ParseUtils: " ++ show (x,y)---doForeignEq :: Monad m => SrcLoc -> [HsName] -> Maybe (String,HsName) -> HsQualType -> HsExp -> m HsDecl-doForeignEq srcLoc names ms qt e = undefined---- FFI parsing--parseExport :: Monad m => String -> HsName -> 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 => Maybe String -> HsName -> m FfiType-parseImport Nothing hn = return $ Import (show hn) mempty-parseImport (Just cn) hn =-    case words cn of-      ["dynamic"]   -> return Dynamic-      ["wrapper"]   -> return Wrapper-      []            -> return $ Import (show hn) mempty-      ("static":xs) -> parseIS [] [] xs-      xs            -> parseIS [] [] xs--parseIS a b ['&':n] | isCName n = return $ ImportAddr n $ Requires a b-parseIS a b [n]     | isCName n = return $ Import     n $ Requires a b-parseIS a b ["&",n] | isCName n = return $ ImportAddr n $ Requires a b-parseIS a b (('-':'l':l):r)     = parseIS a (l:b) r-parseIS a b (i:r)               = parseIS (i:a) b r-parseIS _ _ 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 
@@ -1,901 +0,0 @@-module FrontEnd.Rename(unRename, collectDefsHsModule, renameModule, FieldMap, renameStatement ) where--import Char-import Control.Monad.Identity-import Control.Monad.RWS-import Control.Monad.State-import Control.Monad.Writer-import Control.Applicative-import Data.Monoid-import List-import Maybe-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Traversable as T---import Doc.DocLike(tupled)-import FrontEnd.Desugar (doToExp)-import FrontEnd.SrcLoc hiding(srcLoc)-import FrontEnd.Syn.Traverse-import FrontEnd.Utils-import FrontEnd.HsSyn-import Name.Name as Name hiding(qualifyName)-import Name.Names-import Support.FreeVars-import Util.Gen-import Util.Inst()-import FrontEnd.Warning-import qualified FrontEnd.HsErrors as HsErrors-import qualified Name.VConsts as V--type FieldMap =  (Map.Map Name Int,Map.Map Name [(Name,Int)])-------------------------------------------------------------------------------------- a 'Substitution Table' which is a map from old names to new names--- All names in the current scope are stored in here, with their renamings--type SubTable = Map.Map HsName HsName---- an Identifier Table is a map from renamed names to that identifier's source--- location and binding type----- the monadic state--data ScopeState = ScopeState {-    unique         :: !Int,-    globalSubTable :: Map.Map HsName HsName,  -- Current substition-    typeSubTable   :: Map.Map HsName HsName,  -- type substition table-    errorTable     :: Map.Map HsName String,  -- special error message. else it's just unknown.-    fieldLabels    :: FieldMap-    }---data Env = Env {-    envSubTable  :: Map.Map HsName HsName,  -- all these need to go away-    envNameSpace :: [NameType],-    envModule  :: Module,-    envNameMap :: Map.Map Name (Either String Name),-    envSrcLoc  :: SrcLoc-}--instance Applicative RM where-    pure = return-    (<*>) = ap--newtype RM a = RM (RWS Env [Warning] ScopeState a)-    deriving(Monad,Functor,MonadReader Env, MonadWriter [Warning], MonadState ScopeState)--unRM (RM x) = x--instance MonadWarn RM where-    addWarning w = tell [w]--instance UniqueProducer RM where-    newUniq = do-        u <- gets unique-        modify (\state -> state {unique = (unique state) + 1})-        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----addTopLevels ::  [HsDecl]  -> RM a -> RM a-addTopLevels  hsDecls action = do-    mod <- getCurrentModule-    let (ns,ts) = mconcat (map namesHsDecl hsDecls)-        nm = Map.fromList $ foldl f [] (fsts ns)-        tm = Map.fromList $ foldl f [] (fsts ts)-        f r hsName@Qual {}-            | Just _ <- V.fromTupname hsName, Module "Lhc.Basics" <- mod-                = let nn = hsName in (nn,nn):r-            | nameName tc_Arrow == hsName, Module "Lhc.Basics" == mod-                = let nn = hsName in (nn,nn):r-            | otherwise = error $ "strong bad: " ++ show hsName-        f r z@(UnQual n) = let nn = Qual mod n 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 "multiply-defined" (show n ++ " is defined multiple times: " ++ show xs )-    z ns >> z ts-    modify (\s -> s { globalSubTable = nm `Map.union` globalSubTable s })-    modify (\s -> s { typeSubTable = tm `Map.union` typeSubTable s })-    action---ambig x ys = "Ambiguous Name: " ++ show x ++ "\nCould refer to: " ++ tupled (map show ys)--runRename :: MonadWarn m => (a -> RM a) -> Module -> FieldMap -> [(Name,[Name])] -> a -> m a-runRename doit mod fls ns m = mapM_ addWarning errors >> return renamedMod where-    initialGlobalSubTable = Map.fromList [ (x,y) | ((typ,x),[y]) <- ns', typ == Val || typ == DataConstructor ]-    initialTypeSubTable = Map.fromList [ (x,y) | ((typ,x),[y]) <- ns', typ == TypeConstructor || typ == ClassName ]-    nameMap = Map.fromList $ map f ns where-        f (x,[y]) = (x,Right y)-        f (x,ys)  = (x,Left $ ambig x ys)-    ns' = map fn ns-    fn (n,ns) = (fromName n, map nameName ns)--    errorTab =  Map.fromList [ (x,ambig x ys) | ((typ,x),ys@(_:_:_)) <- ns' ]--    startState = ScopeState {-        typeSubTable   = initialTypeSubTable,-        errorTable     = errorTab,-        unique         = 1,   -- start the counting at 1-        globalSubTable = initialGlobalSubTable,-        fieldLabels    = fls-        }-    startEnv = Env {-        envSubTable = initialGlobalSubTable,-        envNameSpace = [Val,DataConstructor],-        envModule = mod,-        envNameMap  = nameMap,-        envSrcLoc = mempty-    }-    (renamedMod, _, errors) = runRWS (unRM $ doit m) startEnv startState--{-# NOINLINE renameModule #-}-renameModule :: MonadWarn m => FieldMap -> [(Name,[Name])] -> HsModule -> m HsModule-renameModule fls ns m = runRename renameDecls (hsModuleName m) fls ns m--{-# NOINLINE renameStatement #-}-renameStatement :: MonadWarn m => FieldMap -> [(Name,[Name])] -> Module -> HsStmt -> m HsStmt-renameStatement fls ns modName stmt = runRename rename modName fls ns stmt--renameOld :: (SubTable -> RM a) -> RM a-renameOld rm = asks envSubTable >>= rm--withSubTable :: SubTable -> RM a -> RM a-withSubTable st action = local ( \e -> e { envSubTable = st `Map.union` envSubTable e }) action----renameDecls :: HsModule -> RM HsModule-renameDecls tidy = do-        addTopLevels (hsModuleDecls tidy) $ do-        gst <- gets globalSubTable-        withSubTable gst $ do-        decls' <- rename (hsModuleDecls tidy)-        mapM_ HsErrors.hsDeclTopLevel decls'-        return tidy { hsModuleDecls = decls' }---expandTypeSigs :: [HsDecl] -> [HsDecl]-expandTypeSigs ds =  (concatMap f ds) where-    f (HsTypeSig sl ns qt) =  [ HsTypeSig sl [n] qt | n <- ns]-    f d = return d--instance Rename HsDecl where-    rename (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = do-        withSrcLoc srcLoc $ do-        hsPat'    <- rename hsPat-        updateWith hsDecls $ do-        hsDecls'  <- rename hsDecls-        hsRhs'    <- rename hsRhs-        return (HsPatBind srcLoc hsPat' hsRhs' {-where-} hsDecls')--    rename (HsForeignExport a b n t) = do-        withSrcLoc a $ do-        n <- rename n-        updateWith t $ do-            t <- rename t-            return (HsForeignExport a b n t)--    rename (HsForeignDecl a b n t) = do-        withSrcLoc a $ do-        n <- rename n-        updateWith t $ do-        t <- rename t-        return (HsForeignDecl a b n t)--    rename (HsFunBind hsMatches) = do-        hsMatches' <- rename hsMatches-        return (HsFunBind hsMatches')--    rename (HsTypeSig srcLoc hsNames hsQualType) = do-        withSrcLoc srcLoc $ do-        hsNames' <- rename hsNames-        updateWith hsQualType $ do-        hsQualType' <- rename hsQualType-        return (HsTypeSig srcLoc hsNames' hsQualType')-    rename dl@HsDataDecl { hsDeclSrcLoc = srcLoc, hsDeclContext = hsContext, hsDeclName = hsName, hsDeclArgs = hsNames1, hsDeclCons = hsConDecls, hsDeclDerives = hsNames2 } = do-        withSrcLoc srcLoc $ do-        hsName' <- renameTypeName hsName-        updateWith hsNames1 $ do-        hsContext' <- rename hsContext-        hsNames1' <- rename hsNames1-        hsConDecls' <- rename hsConDecls-        -- don't need to rename the hsNames2 as it is just a list of TypeClasses-        hsNames2' <- mapM renameTypeName hsNames2-        return dl { hsDeclContext = hsContext', hsDeclName = hsName', hsDeclArgs = hsNames1', hsDeclCons = hsConDecls', hsDeclDerives = hsNames2' }-    rename (HsTypeDecl srcLoc name hsNames t) = do-        withSrcLoc srcLoc $ do-        hsName' <- renameTypeName name-        updateWith (Set.toList $ freeVars hsNames :: [HsName]) $ do-            hsNames' <- rename hsNames-            t' <- rename t-            return (HsTypeDecl srcLoc  hsName' hsNames' t')-    rename (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) = do-        withSrcLoc srcLoc $ do-        hsName' <- renameTypeName hsName-        updateWith hsNames1 $ do-        hsContext' <- rename hsContext-        hsNames1' <- rename hsNames1-        hsConDecl' <- rename hsConDecl-        -- don't need to rename the hsNames2 as it is just a list of TypeClasses-        hsNames2' <- mapM renameTypeName hsNames2-        return (HsNewTypeDecl srcLoc hsContext' hsName' hsNames1' hsConDecl' hsNames2')-    rename (HsClassDecl srcLoc hsQualType hsDecls) = do-        withSrcLoc srcLoc $ do-        hsQualType' <- updateWith hsQualType  $ rename hsQualType-        doesClassMakeSense hsQualType'-        hsDecls' <- rename hsDecls-        return (HsClassDecl srcLoc hsQualType' hsDecls')-    rename (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = do-        withSrcLoc srcLoc $ 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')-    rename (HsInstDecl srcLoc hsQualType hsDecls) = do-        withSrcLoc srcLoc $ do-        updateWith hsQualType $ do-        hsQualType' <- rename hsQualType-        hsDecls' <- rename hsDecls-        return (HsInstDecl srcLoc hsQualType' hsDecls')-    rename (HsInfixDecl srcLoc assoc int hsNames) = do-        withSrcLoc srcLoc $ do-        hsNames' <- rename hsNames-        return $ HsInfixDecl srcLoc assoc int hsNames'-    rename (HsActionDecl srcLoc pat e) = do-        withSrcLoc srcLoc $ do-        pat <- rename pat-        e <- rename e-        return (HsActionDecl srcLoc pat e)-    rename (HsPragmaProps srcLoc prop hsNames) = do-        withSrcLoc srcLoc $ do-        hsNames' <- rename hsNames-        return (HsPragmaProps  srcLoc prop hsNames')-    rename (HsPragmaRules rs) = do-        rs' <- rename rs-        return $ HsPragmaRules rs'-    rename prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } = do-        withSrcLoc srcLoc $ do-        n <- rename n-        t <- rename t-        m <- getCurrentModule-        i <- newUniq-        return prules { hsDeclUniq = (m,i), hsDeclName = n, hsDeclType = t }-    rename (HsDefaultDecl sl e) = HsDefaultDecl sl <$> rename e-    rename (HsDeclDeriving sl ch) = HsDeclDeriving sl <$> rename ch-    rename h = error $ "renameerr: " ++ show h---instance Rename HsClassHead where-    rename (HsClassHead cx n ts) = do-        updateWith ts $ HsClassHead <$> rename cx <*> renameTypeName n <*> rename ts----instance Rename HsRule where-    rename prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } = do-        withSrcLoc srcLoc $ do-        updateWith (fsts fvs) $ do-        subTable'' <- getUpdates (catMaybes $ snds fvs)-        fvs' <- sequence [ liftM2 (,) (rename x) (withSubTable subTable'' $ rename y)| (x,y) <- fvs]-        e1' <- rename e1-        e2' <- rename e2-        return prules { hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }--doesClassMakeSense :: HsQualType -> RM ()-doesClassMakeSense (HsQualType _ type_) = case type_ of-    (HsTyApp (HsTyCon _) (HsTyVar _)) -> return ()-    (HsTyApp (HsTyApp _ _) _)         -> failRename "Multiparameter typeclasses not supported"-    (HsTyCon _)                       -> failRename "Typeclass with no parameters"-    _                                 -> failRename $ "Invalid type in class declaration: "++show type_--instance Rename HsQualType where-    rename (HsQualType hsContext hsType) = return HsQualType `ap` rename hsContext `ap` rename hsType---instance Rename HsAsst where-    rename (HsAsst hsName1  hsName2s) = do-        hsName1' <- renameTypeName hsName1-        hsName2s' <- mapM renameTypeName hsName2s-        return (HsAsst hsName1' hsName2s')-    rename (HsAsstEq t1 t2) = return HsAsstEq `ap` rename t1 `ap` rename t2---instance Rename HsConDecl where-    rename cd@(HsConDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclConArg = hsBangTypes }) = do-        withSrcLoc srcLoc $ do-        hsName' <- rename hsName-        updateWith  (map hsTyVarBindName (hsConDeclExists cd)) $ do-        es <- rename (hsConDeclExists cd)-        hsBangTypes' <- rename hsBangTypes-        return cd { hsConDeclName = hsName', hsConDeclConArg = hsBangTypes', hsConDeclExists = es }-    rename cd@HsRecDecl { hsConDeclSrcLoc = srcLoc, hsConDeclName = hsName, hsConDeclRecArg = stuff} = do-        withSrcLoc srcLoc $ do-        hsName' <- rename hsName-        subTable <- asks envSubTable-        updateWith (map hsTyVarBindName (hsConDeclExists cd)) $ do-        es <- rename (hsConDeclExists cd)-        stuff' <- sequence [ do ns' <- rename ns; t' <- withSubTable subTable $ rename t; return (ns',t')  |  (ns,t) <- stuff]-        return cd { hsConDeclName = hsName', hsConDeclRecArg = stuff', hsConDeclExists = es }---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 hsTyVarBindName ts)  $ do-        ts' <- rename ts-        v' <- rename v-        return $ HsTyForall ts' v'-    rt (HsTyExists ts v) = do-        updateWith (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 UpdateTable a where-    updateWith :: a -> RM b -> RM b-    updateWith x action = getUpdates x >>= flip withSubTable action--    getUpdates :: a -> RM SubTable-    getUpdates x = Map.unions `fmap` mapM clobberName (getNames x)--    getNames :: a -> [HsName]-    getNames a = []---instance UpdateTable a => UpdateTable [a] where-    getUpdates xs = Map.unions `fmap` mapM getUpdates xs-    getNames xs = concatMap getNames xs--instance UpdateTable HsName where-    getNames x = [x]--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) = return (,) `ap` rename a `ap` rename b---instance Rename a => Rename (Maybe a) where-    rename Nothing = return Nothing-    rename (Just x) = fmap Just $ rename x----instance Rename HsExp where-    rename d = renameOld (renameHsExp d)----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' <- rename hsName-        updateWith hsPats  $ do-        hsPats' <- rename hsPats-        updateWith 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` rename hsName-    rename (HsPInfixApp hsPat1 hsName hsPat2)  = return HsPInfixApp `ap` rename hsPat1 `ap` rename hsName `ap` rename hsPat2-    rename (HsPApp hsName hsPats) = HsPApp <$> rename hsName <*> rename hsPats-    rename (HsPRec hsName hsPatFields) = do-        hsName' <- rename hsName-        hsPatFields' <- rename hsPatFields-        fls <- gets fieldLabels-        buildRecPat fls hsName' hsPatFields'-    rename (HsPAsPat hsName hsPat) = HsPAsPat <$> rename hsName <*> rename hsPat-    rename (HsPTypeSig sl hsPat qt)  = HsPTypeSig sl <$> rename hsPat <*> rename qt-    rename p = traverseHsPat rename p--buildRecPat :: FieldMap -> HsName -> [HsPatField] -> RM HsPat-buildRecPat (amp,fls) n us = case Map.lookup (toName DataConstructor n) amp of-    Nothing -> failRename $ "Unknown Constructor: " ++ show n-    Just t -> do-        let f (HsPFieldPat x p) = case  Map.lookup (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' <- renameHsName hsName gt-        hsPat' <- rename hsPat-        return (HsPFieldPat hsName' hsPat')---instance Rename HsRhs where-    rename (HsUnGuardedRhs hsExp) = fmap HsUnGuardedRhs $ rename hsExp-    rename (HsGuardedRhss rs) = fmap 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')---uqFuncNames :: V.FuncNames HsName-Identity uqFuncNames = T.mapM (return . nameName . toUnqualified) sFuncNames--func_fromRational = (HsVar $ V.func_fromRational uqFuncNames)--newVar = do-    unique <- newUniq-    mod <- getCurrentModule-    let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_var@"))-    return hsName''--wrapInAsPat e = do-    unique <- newUniq-    mod <- getCurrentModule-    let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_as@"))-    return (HsAsPat hsName''  e )--renameHsExp :: HsExp -> SubTable -> RM HsExp-renameHsExp (HsVar hsName) subTable = do-    hsName' <- renameHsName hsName subTable-    return (HsVar hsName')-renameHsExp (HsCon hsName) subTable = do-    hsName' <- renameHsName hsName subTable-    wrapInAsPat (HsCon hsName')--renameHsExp i@(HsLit (HsInt _num)) _st = do return i-renameHsExp i@(HsLit (HsFrac _)) st = do-    z <- renameHsExp func_fromRational st-    return $ HsParen (HsApp z i)-renameHsExp (HsLambda srcLoc hsPats hsExp) subTable = do-    withSrcLoc srcLoc $ do-    updateWith hsPats $ do-    hsPats' <- rename hsPats-    hsExp' <- rename hsExp-    return (HsLambda srcLoc hsPats' hsExp')-renameHsExp (HsLet hsDecls hsExp) subTable = do-    updateWith hsDecls $ do-    hsDecls' <- rename (expandTypeSigs hsDecls)-    mapM_ HsErrors.hsDeclLocal hsDecls'-    hsExp' <- rename hsExp-    return (HsLet hsDecls' hsExp')-renameHsExp (HsCase hsExp hsAlts) subTable = do-    hsExp' <- rename hsExp-    hsAlts' <- rename hsAlts-    return (HsCase hsExp' hsAlts')-renameHsExp (HsDo hsStmts) subTable = do-    e <- doToExp hsStmts-    rename e-renameHsExp (HsList hsExps) subTable = do-    unique <- newUniq-    hsExps' <- rename hsExps-    mod <- getCurrentModule-    let hsName' = Qual mod (HsIdent $ show unique ++ "_as@")-    return (HsAsPat hsName' $ HsList hsExps')-renameHsExp (HsRecConstr hsName hsFieldUpdates) subTable = do-    hsName' <- renameHsName hsName subTable  -- do I need to change this name?-    hsFieldUpdates' <- rename hsFieldUpdates-    fls <- gets fieldLabels-    buildRecConstr fls (hsName':: HsName) (hsFieldUpdates'::[HsFieldUpdate]) -- HsRecConstr hsName' hsFieldUpdates')-renameHsExp (HsRecUpdate hsExp hsFieldUpdates) subTable = do-    hsExp' <- renameHsExp hsExp subTable-    hsFieldUpdates' <- rename hsFieldUpdates-    fls <- gets fieldLabels-    buildRecUpdate fls hsExp' hsFieldUpdates' -- HsRecConstr hsName' hsFieldUpdates')-    --return (HsRecUpdate hsExp' hsFieldUpdates')-renameHsExp (HsEnumFrom hsExp) subTable = do-    let x = desugarEnum "enumFrom" [hsExp]-    hsExp' <- renameHsExp x subTable-    return ( hsExp')-renameHsExp (HsEnumFromTo hsExp1 hsExp2) subTable = do-    let x = desugarEnum "enumFromTo" [hsExp1, hsExp2]-    hsExp' <- renameHsExp x subTable-    return ( hsExp')-renameHsExp (HsEnumFromThen hsExp1 hsExp2) subTable = do-    let x = desugarEnum "enumFromThen" [hsExp1, hsExp2]-    hsExp' <- renameHsExp x subTable-    return ( hsExp')-renameHsExp (HsEnumFromThenTo hsExp1 hsExp2 hsExp3) subTable = do-    let x = desugarEnum "enumFromThenTo" [hsExp1, hsExp2, hsExp3]-    hsExp' <- renameHsExp x subTable-    return ( hsExp')-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-    updateWith hsQualType $ do-    hsQualType' <- rename hsQualType-    return (HsExpTypeSig srcLoc hsExp' hsQualType')-renameHsExp (HsAsPat hsName hsExp) subTable = do-    hsName' <- renameHsName hsName subTable-    hsExp' <- renameHsExp hsExp subTable-    return (HsAsPat hsName' hsExp')-renameHsExp (HsWildCard sl) _ = do-    withSrcLoc sl $ do-    e <- createError HsErrorUnderscore ("_")-    return e-renameHsExp p subTable = traverseHsExp (flip renameHsExp subTable) p--desugarEnum s as = foldl HsApp (HsVar (nameName $ 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 -> HsName -> [HsFieldUpdate] -> RM HsExp-buildRecConstr (amp,fls) n us = do-    undef <- createError HsErrorUninitializedField "Uninitialized Field"-    case Map.lookup (toName DataConstructor n) amp of-        Nothing -> failRename $ "Unknown Constructor: " ++ show n-        Just t -> do-            let f (HsFieldUpdate x e) = case  Map.lookup (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-            con <- wrapInAsPat (HsCon n)-            return $ foldl HsApp con rs--buildRecUpdate ::  FieldMap -> HsExp -> [HsFieldUpdate] -> RM HsExp-buildRecUpdate (amp,fls) n us = do-        sl <- getSrcLoc-        let f (HsFieldUpdate x e) = case  Map.lookup (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 Map.lookup 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-                    con <- wrapInAsPat (HsCon c')-                    let x = foldl HsApp con [ 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-        updateWith hsPat $ do-        hsPat' <- rename hsPat-        updateWith hsDecls $ do-        hsDecls' <- rename (expandTypeSigs hsDecls)-        mapM_ HsErrors.hsDeclLocal hsDecls'-        hsGuardedAlts' <- rename hsGuardedAlts-        return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')------- 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 -> RM (([HsStmt],SubTable))-renameHsStmts (hsStmt:hsStmts) subTable = do-    updateWith hsStmt $ do-      subTable' <- getUpdates hsStmt-      withSubTable subTable' $ do-      hsStmt' <- withSubTable subTable' $ rename hsStmt-      (hsStmts',subTable'') <- renameHsStmts hsStmts subTable'-      return ((hsStmt':hsStmts'),subTable'')-renameHsStmts [] subTable = do-      return ([],subTable)--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' <- renameHsName hsName gt      -- TODO field names should have own namespace-        hsExp' <- rename hsExp-        return (HsFieldUpdate hsName' hsExp')----instance Rename HsName where-    rename n = renameOld $ renameHsName n--renameTypeName n = renameOld $ renameTypeHsName n---- 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 -> RM (HsName)-renameHsName hsName subTable-    | nameName tc_Arrow == hsName = return hsName-    | Qual (Module ('@':m)) (HsIdent i) <- hsName = return $ Qual (Module m) (HsIdent i)-renameHsName hsName subTable = case Map.lookup hsName subTable of-    Just name@(Qual _ _) -> return name-    Just _ -> error "renameHsName"-    Nothing-        | Just n <- V.fromTupname hsName -> return hsName-        | otherwise -> do-            sl <- getSrcLoc-            et <- gets errorTable-            let err = case Map.lookup hsName et of {-                Just s -> s;-                Nothing -> "Unknown name: " ++ show hsName }-            warn sl "undefined-name" err-            -- e <- createError ("Undefined Name: " ++ show hsName)-            return $ hsName-            --return (Qual modName name)--renameTypeHsName hsName subTable  =  gets typeSubTable  >>= \t -> case Map.lookup hsName t of-    Just _ -> renameHsName hsName t-    Nothing -> renameHsName hsName subTable--clobberName :: HsName -> RM SubTable-clobberName hsName = do-    unique     <- newUniq-    currModule <- getCurrentModule-    let hsName'     = renameAndQualify hsName unique currModule-    return $ Map.singleton hsName hsName'---renameAndQualify :: HsName -> Int -> Module -> HsName-renameAndQualify name unique currentMod-    = case renameName name unique of-           UnQual name' -> Qual currentMod name'-           qual_name    -> qual_name---- renames a haskell name with its unique number-renameName :: HsName -> Int -> HsName-renameName n unique = hsNameIdent_u (hsIdentString_u ((show unique ++ "_") ++)) n---- | unRename gets the original identifier name from the renamed version--unRename :: HsName -> HsName-unRename name-   = case isRenamed name of-          False -> name-          True  -> case name of-                      UnQual i   -> UnQual   $ unrenameIdent i-                      Qual mod i -> Qual mod $ unrenameIdent i--unrenameIdent :: HsIdentifier -> HsIdentifier-unrenameIdent = hsIdentString_u unRenameString--isRenamed :: HsName -> Bool-isRenamed (UnQual i)    = isIdentRenamed i-isRenamed (Qual _mod i) = isIdentRenamed i---- an identifier is renamed if it starts with one or more digits--- such an identifier would normally be illegal in Haskell-isIdentRenamed :: HsIdentifier -> Bool-isIdentRenamed i = not $ null $ takeWhile isDigit $ hsIdentString i-----unRenameString :: String -> String-unRenameString s = (dropUnderscore . dropDigits) s where-   dropUnderscore ('_':rest) = rest-   dropUnderscore otherList = otherList-   dropDigits = dropWhile isDigit-----------------------------------------------------------------This section of code updates the current SubTable to reflect the present scope--instance UpdateTable HsDecl where-    getNames hsDecl = fsts $  getHsNamesAndASrcLocsFromHsDecl hsDecl--instance UpdateTable HsPat where-    getNames hsPat = getNamesFromHsPat hsPat--instance UpdateTable HsStmt where-    getNames hsStmt = fsts $  getHsNamesAndASrcLocsFromHsStmt hsStmt----getHsNamesAndASrcLocsFromHsDecl :: HsDecl -> [(HsName, SrcLoc)]-getHsNamesAndASrcLocsFromHsDecl (HsPatBind srcLoc (HsPVar hsName) _ _) = [(hsName, srcLoc)]-getHsNamesAndASrcLocsFromHsDecl (HsPatBind sloc _ _ _) = error $ "non simple pattern binding found (sloc): " ++ show sloc-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)]----- | Collect all names defined in a module as well as their declaration points and--- any subnames they might have.--collectDefsHsModule :: HsModule -> ([(Name,SrcLoc,[Name])],[(Name,Int)])-collectDefsHsModule m = execWriter (mapM_ f (hsModuleDecls m)) where-    --g (b,n,sl,ns) = (b,mod n, sl, map mod ns)-    mod = qualifyName (hsModuleName m)-    toName t n = Name.toName t (mod n)-    -- f :: HsDecl -> Writer [(Name,SrcLoc,[Name])] ()-    tellF xs = tell (xs,[]) >> return ()-    tellS xs = tell ([],xs) >> return ()-    f (HsForeignDecl a _ n _)  = tellF [(toName Val n,a,[])]-    f (HsForeignExport a e _ _)  = tellF [(ffiExportName e,a,[])]-    f (HsFunBind [])  = return ()-    f (HsFunBind (HsMatch a n _ _ _:_))  = tellF [(toName Val n,a,[])]-    f (HsPatBind srcLoc p _ _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getNamesFromHsPat p) ]-    f (HsActionDecl srcLoc p _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getNamesFromHsPat p) ]-    f (HsTypeDecl sl n _ _) = tellF [(toName TypeConstructor n,sl,[])]-    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 (HsNewTypeDecl sl _ n _ c _) = do tellF $ (toName TypeConstructor n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup [c] where-        cs' = namesHsConDecl' toName c-    f cd@(HsClassDecl sl _ ds) = tellF $ (toName Name.ClassName (nameName z),sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]  where-        z = case maybeGetDeclName cd of-            Just x | nameType x == ClassName -> x-            _ -> error "not a class name"-        cs = fst (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 = fst (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-        _ -> []--namesHsDeclTS' toName (HsTypeSig sl ns _) = ((map (rtup sl . toName Val) ns),[])-namesHsDeclTS' toName (HsTypeDecl sl n _ _) = ([(toName TypeConstructor n,sl)],[])-namesHsDeclTS' _ _ = ([],[])---namesHsDecl :: HsDecl -> ([(HsName, SrcLoc)],[(HsName, SrcLoc)])-namesHsDecl (HsForeignDecl a _ n _)  = ([(n,a)],[])-namesHsDecl (HsFunBind hsMatches)  = (getHsNamesAndASrcLocsFromHsMatches hsMatches, [])-namesHsDecl (HsPatBind srcLoc p _ _) = (map (rtup srcLoc) (getNamesFromHsPat p),[])-namesHsDecl (HsTypeDecl sl n _ _) = ([],[(n,sl)])-namesHsDecl HsDataDecl { hsDeclSrcLoc = sl, hsDeclName = n, hsDeclCons = cs } = ( (concatMap namesHsConDecl cs) ,[(n,sl)])-namesHsDecl (HsNewTypeDecl sl _ n _ c _) = ( (namesHsConDecl c),[(n,sl)])-namesHsDecl cd@(HsClassDecl sl _ ds) = (mconcatMap namesHsDeclTS ds) `mappend` ([],[(nameName z,sl)]) where-    z = case maybeGetDeclName cd of-        Just x | nameType x == ClassName -> x-        --       | otherwise ->  parseName ClassName (show x ++ show (nameType x))-        _ -> error "really not a class name"-namesHsDecl _ = mempty--namesHsDeclTS (HsTypeSig sl ns _) = ((map (rtup sl) ns),[])-namesHsDeclTS _ = ([],[])--namesHsConDecl c = (hsConDeclName c,hsConDeclSrcLoc c) : case c of-    -- HsRecDecl { hsConDeclRecArg = ra } -> concatMap (map (rtup (hsConDeclSrcLoc c)) . fst) ra-    _ -> []--getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)]-getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc)-getHsNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []-getHsNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getHsNamesAndASrcLocsFromHsDecl hsDecls---instance UpdateTable HsQualType where-    getNames (HsQualType _hsContext hsType) = getNames hsType--instance UpdateTable HsType where-    getNames t = execWriter (getNamesFromType t)  where-        getNamesFromType (HsTyVar hsName) = tell [hsName]-        getNamesFromType t = traverseHsType_ getNamesFromType t---qualifyName :: Module -> HsName -> HsName-qualifyName _ name@(Qual {}) = name-qualifyName mod (UnQual name) = Qual mod name--
− src/FrontEnd/Representation.hs 
@@ -1,364 +0,0 @@-{--        Copyright:        Mark Jones and The Hatchet Team-                          (see file Contributors)-        Module:           Representation-        Primary Authors:  Mark Jones and Bernie Pope-        Description:      The basic data types for representing objects-                          in the type inference algorithm.-        Notes:            See the file License for license information-                          Large parts of this module were derived from-                          the work of Mark Jones' "Typing Haskell in-                          Haskell", (http://www.cse.ogi.edu/~mpj/thih/)--}--module FrontEnd.Representation(-    Type(..),-    Tyvar(..),-    tyvar,-    Tycon(..),-    fn,-    Pred(..),-    Qual(..),-    Class,-    tForAll,-    tExists,-    MetaVarType(..),-    prettyPrintType,-    fromTAp,-    fromTArrow,-    tassocToAp,-    splitTAp_maybe,-    MetaVar(..),-    tTTuple,-    tTTuple',-    tList,-    tArrow,-    tAp-    )where--import Data.DeriveTH-import Data.Derive.All-import Control.Monad.Identity-import Data.IORef--import StringTable.Atom-import Data.Binary-import Doc.DocLike-import Doc.PPrint(pprint,PPrint)-import FrontEnd.HsSyn-import Name.Name-import Name.Names-import Support.CanType-import Name.VConsts-import qualified Doc.DocLike as D-import Support.Unparse-import Util.VarName-import FrontEnd.Tc.Kind--------------------------------------------------------------------------------------- Types--data MetaVarType = Tau | Rho | Sigma-             deriving(Eq,Ord,Show)--data Type  = TVar { typeVar :: {-# UNPACK #-} !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)---data MetaVar = MetaVar { metaUniq :: !Int, metaKind :: Kind, metaRef :: (IORef (Maybe Type)), metaType :: MetaVarType } -- ^ used only in typechecker-             deriving(Show)--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)---- Dummy instance. We'll never actually serialize a MetaVar.--- FIXME: Prove this statically.-instance Binary MetaVar where-  get = error "get not defined for MetaVar"-  put = error "put not defined for MetaVar"--tList = TCon (Tycon tc_List (Kfun kindStar kindStar))--tArrow = TCon (Tycon tc_Arrow (kindArg `Kfun` kindFunRet `Kfun` kindStar))--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--tAp (TAp c@TCon{} a) b | c == tArrow = TArrow a b-tAp a b = TAp a b--tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl tAp (TCon con) (cas ++ eas)---- Unquantified type variables--data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName ::  !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---instance Show (IORef a) where-    showsPrec _ _ = ("<IORef>" ++)--tyvar n k = Tyvar (toAtom $ show n) n k--instance Eq Tyvar where-    Tyvar { tyvarAtom = x } == Tyvar { tyvarAtom = y } = x == y-    Tyvar { tyvarAtom = x } /= Tyvar { tyvarAtom = y } = x /= y--instance Ord Tyvar where-    compare (Tyvar { tyvarAtom = x }) (Tyvar { tyvarAtom = y }) = compare x y-    (Tyvar { tyvarAtom = x }) <= (Tyvar { tyvarAtom = y }) = x <= y-    (Tyvar { tyvarAtom = x }) >= (Tyvar { tyvarAtom = y }) = x >= y-    (Tyvar { tyvarAtom = x }) <  (Tyvar { tyvarAtom = y })  = x < y-    (Tyvar { tyvarAtom = x }) >  (Tyvar { tyvarAtom = y })  = x > y------ Type constructors--data Tycon = Tycon { tyconName :: Name, tyconKind :: Kind }-    deriving(Eq, Show,Ord)--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)---- Qualified entities-data Qual t =  [Pred] :=> t-              deriving(Show, Eq,Ord)---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-----type Class = Name-------------------------------------------------------------------------------------instance  DocLike d => PPrint d Tyvar where-  pprint tv = tshow (tyvarName tv)--instance Binary Tyvar where-    put (Tyvar aa ab ac) = do-        put aa-        put ab-        put ac-    get = do-        aa <- get-        ab <- get-        ac <- get-        return (Tyvar aa ab ac)---instance FromTupname HsName where-    fromTupname (Qual (Module "Lhc.Basics") (HsIdent xs))  = fromTupname xs-    fromTupname _ = fail "fromTupname: not Prelude"--instance ToTuple HsName where-    toTuple n = (Qual (Module "Lhc.Basics") (HsIdent $ toTuple n))---- pretty printing a HsName, Module and HsIdentifier--instance DocLike d => PPrint d HsName where-   pprint (Qual mod ident)-      -- don't print the Prelude module qualifier-      | mod == Module "Prelude" = pprint ident-      | otherwise               = pprint mod <> text "." <> pprint ident-   pprint (UnQual ident)-      = pprint ident--instance DocLike d => PPrint d Module where-   pprint (Module s) = text s--instance DocLike d => PPrint d HsIdentifier where-   pprint (HsIdent   s) = text s--instance DocLike d => PPrint d Type where-    pprint = prettyPrintType--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 t  = unparse $ runIdentity (runVarNameT (f t)) where-    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 (tyvarAtom 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) = text (show c) <+> prettyPrintType 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--fromTAp t = f t [] where-    f (TAp a b) rs = f a (b:rs)-    f (TArrow a b) rs = f (tAp tArrow 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)--splitTAp_maybe :: Type -> Maybe (Type, Type)-splitTAp_maybe (TAp a b) = Just (a, b)-splitTAp_maybe (TArrow a b) = Just (tAp tArrow a, b)-splitTAp_maybe t = Nothing--instance CanType MetaVar Kind where-    getType mv = metaKind mv--instance CanType Tycon Kind where-    getType (Tycon _ k) = k--instance CanType Tyvar Kind where-    getType = tyvarKind--instance CanType Type Kind where-  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--$(derive makeBinary ''Type)-$(derive makeBinary ''Tycon)-$(derive makeBinary ''Pred)-$(derive makeBinary ''Qual)
− src/FrontEnd/SrcLoc.hs 
@@ -1,122 +0,0 @@-module FrontEnd.SrcLoc where--import Control.Monad.Writer-import Control.Monad.Identity-import Control.Monad-import Control.Applicative-import Data.Traversable-import Data.Foldable--import Data.DeriveTH-import Data.Derive.All-import Data.Monoid-import Data.Generics-import Data.Binary---data SrcLoc = SrcLoc { srcLocFileName :: String, srcLocLine :: !Int, srcLocColumn :: !Int}-    deriving(Data,Typeable,Eq,Ord)-$(derive makeBinary ''SrcLoc)-$(derive makeUpdate ''SrcLoc)--data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc }-    deriving(Data,Typeable,Eq,Ord)-$(derive makeUpdate ''SrcSpan)--bogusASrcLoc = SrcLoc "bogus#" (-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)--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) = 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-
− src/FrontEnd/Syn/Options.hs 
@@ -1,54 +0,0 @@-module FrontEnd.Syn.Options(parseOptions) where---import Text.ParserCombinators.ReadP-import Char-import List----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 
@@ -1,255 +0,0 @@-module FrontEnd.Syn.Traverse where--import qualified Data.Set as Set-import Control.Monad.Writer--import FrontEnd.HsSyn-import Control.Monad.Identity-import FrontEnd.SrcLoc-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--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 (HsAsPat n e) = do-        e' <- fn e-        return $ HsAsPat n e'-    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 (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'-    fFieldUpdate (HsFieldUpdate n e) = do-        e' <- fn e-        return $ HsFieldUpdate n e'-    fnl (Located l e) = 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_ fn p = traverseHsType (traverse_ fn) p >> return ()--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 _ HsTyAssoc = return HsTyAssoc-traverseHsType f x@HsTyExpKind { hsTyType = t } = f t >>= \t' -> return x { hsTyType = t' }-traverseHsType f (HsTyEq a b) = return HsTyEq `ap` f a `ap` f 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_ 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 (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) = 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--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 [hsName]-    getNamesFromPat (HsPAsPat hsName hsPat) = do-        tell [hsName]-        getNamesFromPat hsPat-    getNamesFromPat p = traverseHsPat_ getNamesFromPat p--
− src/FrontEnd/Tc/Class.hs 
@@ -1,267 +0,0 @@-module FrontEnd.Tc.Class(-    Pred,-    ClassHierarchy(),-    splitPreds,-    generalize,-    splitReduce,-    topDefaults,-    freeMetaVarsPreds,-    simplify,-    assertEntailment,-    assertEquivalant,-    Preds-    )where--import Control.Monad.Trans-import Data.Monoid-import List-import 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 FrontEnd.Tc.Kind-import Name.Names-import Name.Name-import Options-import Support.CanType-import FrontEnd.Warning-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 (Set.toList fmvenv) (Set.toList mvs) (simplify ch ps)-    addPreds nps-    quantify mvs' rp r--freeMetaVarsPreds :: Preds -> [MetaVar]-freeMetaVarsPreds ps = concatMap freeMetaVarsPred ps--freeMetaVarsPred :: Pred -> [MetaVar]-freeMetaVarsPred (IsIn _ t) = Set.toList $ freeMetaVars t-freeMetaVarsPred (IsEq t1 t2) = Set.toList (freeMetaVars t1) ++ Set.toList (freeMetaVars t2)---- | split predicates into ones that only mention metavars in the list vs other ones-splitPreds :: Monad m => ClassHierarchy -> [MetaVar] -> Preds -> m (Preds, Preds)-splitPreds h fs ps  = do-    ps' <- toHnfs h ps-    return $ partition (all (`elem` fs) . freeMetaVarsPred) $ 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 [ (tyvarAtom 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---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)---- FIXME: Use sets.-splitReduce :: [MetaVar] -> [MetaVar] -> [Pred] -> Tc ([MetaVar],[Pred], [Pred])-splitReduce fs gs ps = do-    h <- getClassHierarchy-    --liftIO $ putStrLn $ pprint (fs,gs,ps)-    (ds, rs) <- splitPreds h fs ps-    --liftIO $ putStrLn $ pprint (ds,rs)-    (rs',sub) <- genDefaults h (fs++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 (nub gs List.\\ map fst sub, ds,rs')--withDefaults     :: Monad m => ClassHierarchy ->  [MetaVar] -> [Pred] -> m [(MetaVar, [Pred], Type)]-withDefaults h vs ps-  | any null tss = fail $ "withDefaults.ambiguity: " ++ (pprint ps)  ++ pprint vs -- ++ show ps---  | otherwise = fail $ "Zambiguity: " ++ (render $ pprint ps) ++  show (ps,ps',ams)-  | otherwise    = return $ [ (v,qs,head ts) | (v,qs,ts) <- ams ]-    where ams = ambig h vs ps-          tss = [ ts | (v,qs,ts) <- ams ]---- Return retained predicates and a defaulting substitution-genDefaults :: Monad m => ClassHierarchy ->  [MetaVar] -> [Pred] -> m ([Pred],[(MetaVar,Type)])-genDefaults h vs ps = do-    ams <- withDefaults h vs ps-    let ps' = [ p | (v,qs,ts) <- ams, p<-qs ]-        vs  = [ (v,t)  | (v,qs,t) <- ams ]-    return (ps \\ ps',  vs)---- ambiguities from THIH + call to candidates-ambig :: ClassHierarchy -> [MetaVar] -> [Pred] -> [(MetaVar,[Pred],[Type])]--ambig h vs ps-  = [ (v, qs, defs h v qs) |-         v <- nub (freeMetaVarsPreds ps) \\ vs,-         let qs = [ p | p<-ps, v `elem` 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 ]---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 [] 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 
@@ -1,7 +0,0 @@-module FrontEnd.Tc.Class(simplify,FrontEnd.Class.ClassHierarchy) where--import FrontEnd.Class-import FrontEnd.Tc.Type---simplify :: ClassHierarchy -> [Pred] -> [Pred]
− src/FrontEnd/Tc/Kind.hs 
@@ -1,174 +0,0 @@-module FrontEnd.Tc.Kind(-    Kind(..),-    KBase(..),-    Kindvar(..),-    KindConstraint(..),-    kindCombine,-    kindStar,-    kindUTuple,-    kindFunRet,-    kindHash,-    kindArg,-    isSubsumedBy,-    unfoldKind-    ) where-import Data.DeriveTH-import Data.Derive.All-import Data.Monoid-import Control.Monad-import Data.IORef--import Data.Binary-import Doc.DocLike-import Doc.PPrint(pprint,pprintPrec,PPrint)-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--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--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--infixr `Kfun`--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 :: !Int,-    kvarRef :: 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-   pprintPrec _ (KBase b) = pprint b-   pprintPrec _ (KVar kindVar)   = pprint kindVar-   pprintPrec p k | p > 9 = parens $ pprint k-   pprintPrec _ (Kfun k1 k2) = pprintPrec 10 k1 <+> text "->" <+> pprint 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]--$(derive makeBinary ''KBase)-$(derive makeBinary ''Kind)
− src/FrontEnd/Tc/Main.hs 
@@ -1,927 +0,0 @@-module FrontEnd.Tc.Main (tiExpr, tiProgram, makeProgram, isTypePlaceholder ) where--import Control.Monad.Writer-import Data.Graph(stronglyConnComp, SCC(..))-import IO(hFlush,stdout)-import List-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Text.PrettyPrint.ANSI.Leijen as P--import Control.Monad.Reader-import FrontEnd.DeclsDepends(getDeclDeps)-import FrontEnd.Diagnostic-import Doc.DocLike-import Doc.PPrint as PPrint-import FrontEnd.Desugar(doToExp)-import FrontEnd.KindInfer-import FrontEnd.SrcLoc-import FrontEnd.Tc.Class-import FrontEnd.Tc.Monad hiding(listenPreds)-import FrontEnd.Tc.Type-import FrontEnd.Tc.Kind-import FrontEnd.Tc.Unify-import FrontEnd.Utils(getDeclName)-import GenUtil-import FrontEnd.HsPretty-import FrontEnd.HsSyn-import Name.Name-import Name.Names-import Name.VConsts-import Options-import Support.FreeVars-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]])---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)-    (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@(HsAsPat n (HsCon v)) as typ = do-    let vname = toName DataConstructor v-    let nname = toName Val n-    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "tcApps: " ++ (show nname ++ "@" ++ show vname)-    addToCollectedEnv (Map.singleton (toName Val n) typ)-    tcKnownApp e False vname as typ--tcApps e as typ = tcApps' e as typ---- the fall through case-tcApps' e as typ = do-    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-    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)--newHsVar ns = do-    nn <- newUniq-    return $ toName Val (ns ++ "@",show nn)---isTypePlaceholder :: HsName -> Bool-isTypePlaceholder (Qual (Module "Wild@") _) = True-isTypePlaceholder (Qual (Module "As@") _) = True-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 = withContext (simpleMsg $ "in the case expression\n   case " ++ show e ++ " of ...") $ do-    scrutinee <- newBox kindFunRet-    e' <- tcExpr e scrutinee-    alts' <- mapM (tcAlt scrutinee typ) alts-    (ne,ap) <- wrapInAsPat (HsCase e' alts')-    addToCollectedEnv (Map.singleton ap typ)-    return ne---tiExpr (HsCon conName) typ = do-    sc <- lookupName (toName DataConstructor conName)-    sc `subsumes` typ-    return (HsCon conName)--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))-    (ne,n) <- wrapInAsPat (HsLit l)-    addToCollectedEnv (Map.singleton n ty)-    return ne---tiExpr (HsLit l@(HsInt _)) typ = do-    t <- tiLit l-    t `subsumes` typ-    (ne,n) <- wrapInAsPat (HsLit l)-    addToCollectedEnv (Map.singleton n typ)-    return ne--tiExpr err@HsError {} typ = do-    unBox typ-    (ne,n) <- wrapInAsPat err-    addToCollectedEnv (Map.singleton n typ)-    return ne--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 =  withContext (locMsg sloc "in the annotated expression" $ render $ ppHsExp 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 = withContext (makeMsg "in the application" $ render $ ppHsExp $ 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 = withContext (makeMsg "in the infix application" $ render $ ppHsExp 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 = withContext (makeMsg "in the negative expression" $ render $ ppHsExp expr) $ do-        e <- tcExpr e typ-        addPreds [IsIn class_Num typ]-        return (HsNegApp e)----- ABS1-tiExpr expr@(HsLambda sloc ps e) typ = withContext (locSimple sloc $ "in the lambda expression\n   \\" ++ show (pprint 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 = withContext (simpleMsg $ "in the if expression\n   if " ++ show e ++ "...") $ do-    e <- tcExpr e tBool-    e1 <- tcExpr e1 typ-    e2 <- tcExpr e2 typ-    return (HsIf e e1 e2)--tiExpr tuple@(HsTuple exps@(_:_)) typ = withContext (makeMsg "in the tuple" $ render $ ppHsExp tuple) $ do-    (_,exps') <- tcApps (HsCon (toTuple (length exps))) exps typ-    return (HsTuple exps')--tiExpr tuple@(HsUnboxedTuple exps) typ = withContext (makeMsg "in the unboxed tuple" $ render $ ppHsExp 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-    return (HsList [])---- special case for the empty list-tiExpr (HsList []) typ = do-    v <- newVar kindStar-    let lt = TForAll [v] ([] :=> TAp tList (TVar v))-    lt `subsumes` typ-    return (HsList [])---- non empty list-tiExpr expr@(HsList exps@(_:_)) (TAp tList' v) | tList == tList' = withContext (makeMsg "in the list " $ render $ ppHsExp expr) $ do-        exps' <- mapM (`tcExpr` v) exps-        return (HsList exps')---- non empty list-tiExpr expr@(HsList exps@(_:_)) typ = withContext (makeMsg "in the list " $ render $ ppHsExp expr) $ do-        v <- newBox kindStar-        exps' <- mapM (`tcExpr` v) exps-        (TAp tList v) `subsumes` typ-        return (HsList exps')--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 = withContext (makeMsg "in the let binding" $ render $ ppHsExp 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----------------------------------------------------------------------------------- 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 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_Int__ 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 (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 (toTuple (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 (Set.toList fs) (Set.toList vss) ps'-    addPreds ds-    sc' <- if restricted [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 (Set.toList fs) (Set.toList $ foldr1 Set.intersection vss) ps'-    addPreds ds-    scs' <- if restricted bs then do-        let gs' = gs Set.\\ Set.fromList (freeVars rs)-        addPreds rs-        mapM (quantify (Set.toList gs') []) ts'-     else mapM (quantify (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)--tcPragmaDecl 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]--tcPragmaDecl (HsPragmaRules rs) = do-    rs' <- mapM tcRule rs-    return [HsPragmaRules rs']----- foreign decls are accumulated by tiExpl-tcPragmaDecl fd@(HsForeignDecl _ _ n qt) = do-    kt <- getKindEnv-    s <- hsQualTypeToSigma kt qt-    addToCollectedEnv (Map.singleton (toName Val n) s)-    return []--tcPragmaDecl fd@(HsForeignExport _ e n qt) = do-    kt <- getKindEnv-    s <- hsQualTypeToSigma kt qt-    addToCollectedEnv (Map.singleton (ffiExportName e) s)-    return []--tcPragmaDecl _ = return []--tcRule prule@HsRule { 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 [] ps1-                    ([],rs2) <- splitPreds ch [] 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-            -- SamB 2009.01.12:-            --   This doesn't make any sense to me -- it seems to break stuff ...-            -- 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-    (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)--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--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--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 (Set.toList env) (freeMetaVarsPreds qs) ps-    assertEntailment qs (rs ++ ds)-    return ret--restricted   :: [HsDecl] -> Bool-restricted bs = any isHsActionDecl bs || (fopts FO.MonomorphismRestriction && any isSimpleDecl bs) where-   isSimpleDecl :: (HsDecl) -> Bool-   isSimpleDecl (HsPatBind _sloc _pat _rhs _wheres) = True-   isSimpleDecl _ = False--{---------------------------------------------------------------------------------------tiStmts ::  TypeEnv -> [(HsStmt)] -> TI ([Pred], TypeEnv)--tiStmts = tiStmtsAcc [] Map.empty--tiStmtsAcc ::   [Pred] -> TypeEnv -> TypeEnv -> [(HsStmt)] -> TI ([Pred], TypeEnv)-tiStmtsAcc predAcc envAcc _ []-   = return (predAcc, envAcc)--tiStmtsAcc predAcc envAcc env (s:ss)-   = do-        (newPs, newEnv) <- tiStmt (envAcc `Map.union` env) s-        tiStmtsAcc (newPs ++ predAcc) (newEnv `Map.union` envAcc) env ss--tiStmt :: TypeEnv -> (HsStmt) -> TI ([Pred], TypeEnv)---- with lists:--- x <- xs--- xs :: [a]--- x :: a--tiStmt env expr@(HsGenerator srcLoc pat e)-   = withContext-        (locMsg srcLoc "in the generator " $ render $ ppHsStmt expr) $-        do-        (ePs, eEnv, eT) <- tiExpr env e-        (patPs, patEnv, patT) <- tiPat pat-        unify eT (TAp tList patT)-        return (ePs ++ patPs, eEnv `Map.union` patEnv)--tiStmt env stmt@(HsQualifier e)-   = withContext (makeMsg "in " $ render $ ppHsStmt stmt) $-        do-        (ePs, eEnv, eT) <- tiExpr env e-        unify eT tBool-        return (ePs, eEnv)--tiStmt env stmt@(HsLetStmt decls)-   = withContext-         (makeMsg "in let statement" $ render $ ppHsStmt stmt) $-         do-         sigEnv <- getSigEnv-         let bgs = getFunDeclsBg sigEnv decls-         tiSeq tiBindGroup env bgs--------------------------------------------------------------------------------------}--getBindGroupName (expl,impls) =  map getDeclName (snds expl ++ concat (rights impls) ++ lefts impls)---tiProgram ::  [BindGroup] -> [HsDecl] -> Tc [HsDecl]-tiProgram bgs es = ans where-    ans = do-        (r,ps) <- listenPreds $ f bgs [] mempty-        ps <- flattenType ps-        ch <- getClassHierarchy-        ([],rs) <- splitPreds ch [] ps-        topDefaults rs-        return r-        --ps <- return $ simplify ch ps-        --liftIO $ mapM_ (putStrLn.show) ps-        --return r-    f (bg:bgs) rs cenv  = do-        ((ds,env),ps) <- listenPreds (tcBindGroup bg)-        ch <- getClassHierarchy-        withContext (makeMsg "in the binding group:" $ show (getBindGroupName bg)) $ do-            ([],leftovers) <- splitPreds ch [] ps-            --topDefaults leftovers-            return ()-        when verbose $ liftIO $ do putChar '.'; hFlush stdout-        localEnv env $ f bgs (ds ++ rs) (env `mappend` cenv)-    f [] rs _cenv = do-        ch <- getClassHierarchy-        (pdecls,ps) <- listenPreds $ mapM tcPragmaDecl es-        withContext (makeMsg "in the pragmas:" $ "rules") $ do-            ([],leftovers) <- splitPreds ch [] ps-            --topDefaults leftovers-            return ()-        when verbose $ liftIO $ putStrLn "!"-        return (rs ++ concat pdecls)---- Typing Literals--tiLit :: HsLiteral -> Tc Tau-tiLit (HsChar _) = return tChar-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------tiProgram = undefined----------------------------------------------- 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 
@@ -1,286 +0,0 @@-module FrontEnd.Tc.Module (tiModules',TiData(..)) where--import Char-import Control.Monad.Writer-import IO-import List-import Maybe-import Monad-import Text.PrettyPrint.ANSI.Leijen as PPrint-import qualified Data.Map as Map-import qualified Data.Set as Set--import FrontEnd.DataConsAssump     (dataConsEnv)-import DataConstructors-import FrontEnd.DeclsDepends       (getDeclDeps, debugDeclBindGroups)-import FrontEnd.DependAnalysis     (getBindGroups)-import DerivingDrift.Drift-import Doc.PPrint as PPrint-import FrontEnd.Class-import FrontEnd.Desugar-import FrontEnd.Exports-import FrontEnd.Infix-import FrontEnd.KindInfer-import FrontEnd.Rename-import FrontEnd.Tc.Main-import FrontEnd.Tc.Monad-import FrontEnd.Tc.Type-import FrontEnd.Utils-import FrontEnd.Warning-import Ho.Type-import Ho.Collected-import FrontEnd.HsSyn-import Info.Types-import Name.Name as Name-import Options-import FrontEnd.TypeSigs           (collectSigs, listSigsToSigEnv)-import FrontEnd.TypeSynonyms-import FrontEnd.TypeSyns---import ClassAliases-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"---render :: Doc -> String-render = show--buildFieldMap :: Ho -> [ModInfo] -> FieldMap-buildFieldMap ho ms = (ans',ans) where-        theDefs = [ (x,z) | (x,_,z) <- concat $ map modInfoDefs ms, nameType x == DataConstructor ]-        allDefs = theDefs ++ [ (x,z) | (x,(_,z)) <- Map.toList (hoDefs $ hoExp ho), 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 ++ getConstructorArities (hoDataTable $ hoBuild ho)--processModule :: FieldMap -> ModInfo -> IO ModInfo-processModule defs m = do-    when (dump FD.Parsed) $ do-        putStrLn " \n ---- parsed code ---- \n";-        putStrLn $ HsPretty.render-            $ HsPretty.ppHsModule-                $ modInfoHsModule m-    -- driftDerive only uses IO to print the derived instances.-    zmod' <-  driftDerive (modInfoHsModule m)-    let mod = desugarHsModule (zmod')-    let (mod',errs) = runWriter $ renameModule defs (modInfoImport m)  mod-    when (dump FD.Renamed) $ do-        putStrLn " \n ---- renamed code ---- \n"-        putStrLn $ HsPretty.render $ HsPretty.ppHsModule $  mod'-    processErrors errs-    return $ modInfoHsModule_s mod' m----- 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 ]---- FIXME: Use an warnings+writer+error monad instead of IO.-tiModules' ::  CollectedHo -> [ModInfo] -> IO (Ho,TiData)-tiModules' cho ms = do-    let me = choHo cho-        hoB = hoBuild me---    let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps me, nameType x == Name.Val ]---        importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps me, nameType x ==  Name.DataConstructor ]-    let importClassHierarchy = hoClassHierarchy hoB-        importKindEnv = hoKinds hoB-    wdump FD.Progress $ do-        putErrLn $ "Typing: " ++ show ([ m | Module m <- map modInfoName ms])-    let fieldMap = buildFieldMap me ms-    -- 'processModule' doesn't need IO. We can use a plain writer+error monad.-    ms <- mapM (processModule fieldMap) ms-    let thisFixityMap = buildFixityMap (concat [ filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])-    let fixityMap = thisFixityMap  `mappend` hoFixities hoB-    let thisTypeSynonyms =  (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])-    let ts = thisTypeSynonyms `mappend` hoTypeSynonyms hoB-    -- 'expandTypeSyns' is in the Warning monad and doesn't require IO.-    let f x = expandTypeSyns ts (modInfoHsModule x) >>= return . FrontEnd.Infix.infixHsModule fixityMap >>= \z -> return (modInfoHsModule_s ( z) x)-    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, isHsNewTypeDecl, isHsClassDecl, isHsClassAliasDecl]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls--    wdump FD.Progress $ do-        putErrLn $ "Kind inference"-    kindInfo <- kiDecls importKindEnv classAndDataDecls--    when (dump FD.Kind) $-         do {putStrLn " \n ---- kind information ---- \n";-             putStrLn $ render $ pprint kindInfo }--    -- collect types for data constructors--    let localDConsEnv =  dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)--    wdump FD.Dcons $ do-        putStr "\n ---- data constructor assumptions ---- \n"-        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList localDConsEnv]---    --let globalDConsEnv = localDConsEnv `Map.union` importDConsEnv---    let smallClassHierarchy = makeClassHierarchy importClassHierarchy kindInfo ds-    let cHierarchyWithInstances = 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, isClassRecord as ]-        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 -- rInstDecls---    when (not (null liftedInstances) && (dump FD.Instance) ) $ do-        putStrLn "  ---- lifted instance declarations ---- "-        putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) liftedInstances-        putStrLn $ 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 $ render $ pprintEnvMap sigEnv}-    let bindings = (funPatBinds ++ filter (not . isHsPragmaRules) 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 (render . PPrint.pprint) $  program--    -- type inference/checking for all variables--    when (dump FD.AllTypes) $ do-        putStrLn "  ---- all types ---- "-        putStrLn $ render $ pprintEnvMap (sigEnv `mappend` localDConsEnv `mappend` hoAssumps hoB)--    wdump FD.Progress $ do-        putErrLn $ "Type inference"-    let moduleName = modInfoName tms-        (tms:_) = ms-    let tcInfo = tcInfoEmpty {-        tcInfoEnv = hoAssumps hoB `mappend` localDConsEnv, -- (importVarEnv `mappend` globalDConsEnv),-        tcInfoSigEnv = sigEnv,-        tcInfoModName =  show moduleName,-        tcInfoKindInfo = kindInfo,-        tcInfoClassHierarchy = cHierarchyWithInstances-        }--    (localVarEnv,checkedRules,coercions,tcDs) <- withOptionsT (modInfoOptions tms) $ runTc tcInfo $ do-        (tcDs,out) <- listen (tiProgram program (ds ++ filter isHsPragmaRules liftedInstances))-        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,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 hoBld = mempty {-            hoAssumps = Map.filterWithKey -                           (\k _ -> (k `member` allExports)-                                    || (k `elem` (map snd . concatMap classDefaults . classRecords $-                                                      smallClassHierarchy)))-                           allAssumps,-            hoFixities = restrictFixityMap (`member` allExports) thisFixityMap,-            -- TODO - this contains unexported names, we should filter these before writing to disk.-            hoKinds = externalKindEnv,-            --hoKinds = restrictKindEnv (`member` allExports) kindInfo,-            hoClassHierarchy = smallClassHierarchy,-            hoTypeSynonyms = restrictTypeSynonyms (`member` allExports) thisTypeSynonyms-        }-        hoEx = mempty {-            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]-        }-        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-        }-    return (mempty { hoBuild = hoBld, hoExp = hoEx },tiData)-
− src/FrontEnd/Tc/Monad.hs 
@@ -1,555 +0,0 @@-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,-    getKindEnv,-    getModName,-    getSigEnv,-    evalFullType,-    inst,-    listenCheckedRules,-    listenPreds,-    listenCPreds,-    localEnv,-    lookupName,-    newBox,-    newMetaVar,-    newVar,-    quantify,-    runTc,-    skolomize,-    tcInfoEmpty,-    toSigma,-    unBox,-    evalType,-    unificationError,-    varBind,-    zonkKind,-    withContext,-    withMetaVars-    ) where--import Control.Monad.Reader-import Control.Monad.Writer-import qualified Data.Traversable as T--import Data.DeriveTH-import Data.Derive.All-import Data.IORef-import Data.Monoid-import List-import Maybe-import qualified Data.Map as Map-import qualified Data.Set as Set-import System---import StringTable.Atom-import FrontEnd.Diagnostic-import Doc.DocLike-import Doc.PPrint-import FrontEnd.Class-import FrontEnd.KindInfer-import FrontEnd.SrcLoc(bogusASrcLoc,MonadSrcLoc(..))-import FrontEnd.Tc.Type-import FrontEnd.Tc.Kind-import GenUtil-import Name.Name-import Name.Names-import Options-import Options-import Support.CanType-import Support.FreeVars-import Support.Tickle-import FrontEnd.Warning-import qualified FlagDump as FD-import {-# SOURCE #-} FrontEnd.Tc.Class(ClassHierarchy,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            :: IORef Int,-    tcCollectedEnv      :: IORef (Map.Map Name Sigma),-    tcCollectedCoerce   :: IORef (Map.Map Name CoerceTerm),-    tcCurrentEnv        :: Map.Map Name Sigma,-    tcCurrentScope      :: Set.Set MetaVar,-    tcRecursiveCalls    :: Set.Set Name,-    tcInstanceEnv       :: InstanceEnv,-    tcOptions           :: Opt  -- module specific options-    }--data Output = Output {-    collectedPreds   :: Preds,-    existentialPreds :: Preds,-    constraints      :: [Constraint],-    checkedRules     :: [Rule],-    existentialVars  :: [Tyvar],-    outKnots         :: [(Name,Name)]-    }---- | 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 :: String,-    tcInfoKindInfo :: KindEnv,-    tcInfoClassHierarchy :: ClassHierarchy-    }--$(derive makeUpdate ''TcEnv)-$(derive makeUpdate ''Output)-$(derive makeMonoid ''Output)--newtype Tc a = Tc (ReaderT TcEnv (WriterT Output IO) a)-    deriving(MonadFix,MonadIO,MonadReader TcEnv,MonadWriter Output,Functor)---- | run a computation with a local environment-localEnv :: TypeEnv -> Tc a -> Tc a-localEnv te act = do-    te' <- mapM (\ (x,y) -> do y <- flattenType y; return (x,y)) (Map.toList te)-    if any isBoxy (snds te') then-        fail $ "localEnv error!\n" ++ show te-     else local (tcCurrentEnv_u (Map.fromList te' `Map.union`)) 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,-        tcCurrentEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,-        tcVarnum = vn,-        tcDiagnostics = [Msg Nothing $ "Compilation of module: " ++ tcInfoModName tcInfo],-        tcInfo = tcInfo,-        tcRecursiveCalls = mempty,-        tcInstanceEnv = makeInstanceEnv (tcInfoClassHierarchy tcInfo),-        tcCurrentScope = mempty,-        tcOptions = opt-        }-    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 = [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)--getModName :: Tc String-getModName = asks ( tcInfoModName . tcInfo)----dConScheme :: Name -> Tc Sigma-dConScheme conName = do-    env <- asks tcCurrentEnv-    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 <- asks tcCurrentEnv-    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)-                          <$> "env:" <+> pprint env-                          --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 Atom 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 (tyvarAtom tv) ts of-            Just t'  -> t'-            Nothing -> (TVar tv)-    inst mm ts (TForAll as qt) = TForAll as (inst mm (foldr Map.delete ts (map tyvarAtom as)) qt)-    inst mm ts (TExists as qt) = TExists as (inst mm (foldr Map.delete ts (map tyvarAtom 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 -- (IsIn c t) = IsIn c (inst mm ts t)---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 = [ Equality { constraintSrcLoc = sl, constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] }--addConstraints :: [Constraint] -> Tc ()-addConstraints ps = Tc $ tell mempty { constraints = 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,constraints x)) action--listenCheckedRules :: Tc a -> Tc (a,[Rule])-listenCheckedRules action = censor (\x -> x { checkedRules = mempty }) $ listens checkedRules action--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 List.\\ freeVars (f t)-    tell mempty { existentialVars = eqvs }-    (_,t) <- freshInstance Sigma (TForAll (vs 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 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 [ (tyvarAtom bt,s) | (bt,s) <- vs ]) ps-    return (sortGroupUnderFG fst snd vs,t')-----freeMetaVarsEnv :: Tc (Set.Set MetaVar)-freeMetaVarsEnv = do-    env <- asks tcCurrentEnv-    xs <- flip mapM (Map.elems env)  $ \ x -> do-        x <- flattenType x-        return $ freeMetaVars x-    return (Set.unions xs)--quantify :: [MetaVar] -> [Pred] -> Rho -> Tc Sigma-quantify vs ps r | not $ any isBoxyMetaVar vs = do-    vs <- mapM groundKind vs-    r <- flattenType r-    nvs <- mapM (newVar . fixKind . metaKind) vs-    sequence_ [ varBind mv (TVar v) | v <- nvs |  mv <- vs ]-    (ps :=> r) <- flattenType (ps :=> r)-    ch <- getClassHierarchy-    return $ TForAll nvs (FrontEnd.Tc.Class.simplify ch ps :=> r)---- 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 = liftIO $ processErrors [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 = "(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
− src/FrontEnd/Tc/Type.hs 
@@ -1,336 +0,0 @@-module FrontEnd.Tc.Type(-    Kind(..),-    KBase(..),-    MetaVar(..),-    MetaVarType(..),-    Pred(..),---    Preds(),-    Qual(..),-    Tycon(..),-    Type(..),-    Tyvar(..),-    kindStar,-    kindFunRet,-    kindUTuple,-    unfoldKind,-    fn,---    followTaus,-    fromTAp,-    fromTArrow,-    splitTAp_maybe,-    module FrontEnd.Tc.Type,-    prettyPrintType,---    readMetaVar,-    tForAll,-    tList,-    tArrow,-    tAp,---    Constraint(..),---    applyTyvarMap,-    Class(),-    Kindvar(..),-    tTTuple,-    tTTuple',-    tyvar-    ) where--import Control.Monad.Writer-import Data.IORef-import Data.List-import Data.Monoid-import qualified Data.Map as Map-import qualified Data.Set as S--import Doc.DocLike-import Doc.PPrint-import Name.Name-import FrontEnd.SrcLoc-import FrontEnd.Tc.Kind-import FrontEnd.Representation-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 [ (tyvarAtom v,t) | (v,t) <- ts ]-    -- XXX name capture!-    f mp (TForAll as qt) = TForAll as (fq (foldr Map.delete mp (map tyvarAtom as)) qt)-    f mp (TExists as qt) = TExists as (fq (foldr Map.delete mp (map tyvarAtom as)) qt)-    f mp (TVar tv) = case Map.lookup (tyvarAtom 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 { 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----data UnVarOpt = UnVarOpt {-    openBoxes :: Bool,-    failEmptyMetaVar :: Bool-    }--flattenType t =  unVar UnVarOpt { openBoxes = True, failEmptyMetaVar = False } t----class UnVar t where-    unVar' ::  UnVarOpt -> t -> IO t--unVar :: (UnVar t, MonadIO m) => UnVarOpt -> t -> m t-unVar opt t = liftIO (unVar' opt t)--instance UnVar t => UnVar [t] where-   unVar' opt xs = mapM (unVar' opt) xs--instance UnVar Pred where-    unVar' opt (IsIn c t) = IsIn c `liftM` unVar' opt t-    unVar' opt (IsEq t1 t2) = liftM2 IsEq (unVar' opt t1) (unVar' opt t2)--instance (UnVar a,UnVar b) => UnVar (a,b) where-    unVar' opt (a,b) = do-        a <- unVar' opt a-        b <- unVar' opt b-        return (a,b)--instance UnVar t => UnVar (Qual t) where-    unVar' opt (ps :=> t) = liftM2 (:=>) (unVar' opt ps) (unVar' opt t)--instance UnVar Type where-    unVar' opt tv =  do-        let ft (TForAll vs qt) = do-                qt' <- unVar' opt qt-                return $ TForAll vs qt'-            ft (TExists vs qt) = do-                qt' <- unVar' opt qt-                return $ TExists vs qt'-            ft t@(TMetaVar _) = if failEmptyMetaVar opt then fail $ "empty meta var" ++ prettyPrintType t else return t-            ft t = tickleM (unVar' opt . (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---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) = return IsEq `ap` f t1 `ap` f t2--instance Tickleable Type Type where-    tickleM f (TAp l r) = return tAp `ap` f l `ap` f r-    tickleM f (TArrow l r) = return TArrow `ap` f l `ap` f r-    tickleM f (TAssoc c cas eas) = return (TAssoc c) `ap` mapM f cas `ap` mapM f eas-    tickleM f (TForAll ta (ps :=> t)) = do-        ps <- mapM (tickleM f) ps-        return (TForAll ta . (ps :=>)) `ap` f t-    tickleM f (TExists ta (ps :=> t)) = do-        ps <- mapM (tickleM f) ps-        return (TExists ta . (ps :=>)) `ap` 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)---ptrans b f = if b then f else id--instance Monoid CoerceTerm where-    mempty = CTId-    mappend = composeCoerce--ctFun CTId = CTId-ctFun x = CTFun x-ctAbs [] = CTId-ctAbs xs = CTAbs xs-ctAp [] = CTId-ctAp xs = CTAp xs-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' opt (CTAp ts) = CTAp `liftM` unVar' opt ts-    unVar' opt (CTFun ct) = CTFun `liftM` unVar' opt ct-    unVar' opt (CTCompose c1 c2) = liftM2 CTCompose (unVar' opt c1) (unVar' opt c2)-    unVar' _ x = return x----
− src/FrontEnd/Tc/Unify.hs 
@@ -1,327 +0,0 @@--module FrontEnd.Tc.Unify(-    subsumes,-    boxyMatch,-    listenSolvePreds-    ) where--import Control.Monad.Writer-import Control.Monad.Reader-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.Monad-import FrontEnd.Tc.Type-import FrontEnd.Tc.Kind-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)----    -- 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----    -- 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 [ (tyvarAtom a2,TVar a1) | a1 <- as1 | a2 <- as2 ]) qt2-        printRule "SEQ2"-        boxyMatch r1 r2-        assertEquivalant ps1 ps2-        return False---    bm t1 t2 | Just (a, b) <- splitTAp_maybe t1, Just (c, d) <- splitTAp_maybe t2 = 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 
@@ -1,122 +0,0 @@-{---------------------------------------------------------------------------------        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.KindInfer-import FrontEnd.Syn.Traverse-import FrontEnd.Tc.Type-import FrontEnd.SrcLoc-import FrontEnd.HsSyn-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 
@@ -1,112 +0,0 @@--module FrontEnd.TypeSynonyms (-    removeSynonymsFromType,-    declsToTypeSynonyms,-    TypeSynonyms,-    restrictTypeSynonyms,-    showSynonym-    ) where--import Control.Monad.Writer-import Data.Monoid-import Data.Binary-import List-import qualified Data.Map as Map--import Doc.DocLike-import FrontEnd.SrcLoc-import GenUtil-import Util.UniqueMonad-import FrontEnd.Syn.Traverse-import FrontEnd.HsSyn-import Name.Name-import Util.HasSize-import FrontEnd.Warning---newtype TypeSynonyms = TypeSynonyms (Map.Map Name ([HsName], HsType, SrcLoc))-    deriving(Monoid,HasSize)--instance Binary TypeSynonyms where-    put (TypeSynonyms ts) = put ts-    get = fmap TypeSynonyms get--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"---- | 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'] ]--removeSynonymsFromType :: MonadWarn m => TypeSynonyms -> HsType -> m HsType-removeSynonymsFromType syns t = evalTypeSyms  syns t--quantifyHsType :: [HsName] -> HsQualType -> HsType-quantifyHsType inscope t-  | null vs, null (hsQualTypeHsContext 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 "type-synonym-partialap" ("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 (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 $ 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 
@@ -1,551 +0,0 @@-module FrontEnd.TypeSyns( expandTypeSyns, expandTypeSynsStmt ) where--import Control.Monad.State-import Control.Monad.Writer-import qualified Data.Traversable as T-import List--import FrontEnd.Desugar (doToExp)-import FrontEnd.SrcLoc hiding(srcLoc)-import FrontEnd.HsSyn-import FrontEnd.TypeSynonyms-import FrontEnd.Warning-import FrontEnd.Syn.Traverse---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, hsDeclName = hsName, hsDeclArgs = hsNames1, hsDeclCons = hsConDecls  } subTable = do-    hsName' <- renameTypeHsName hsName subTable-    hsContext' <- renameHsContext hsContext subTable-    hsNames1' <- renameHsNames hsNames1 subTable-    hsConDecls' <- renameHsConDecls hsConDecls subTable-    -- don't need to rename the hsNames2 as it is just a list of TypeClasses-    return dl { hsDeclContext = hsContext', hsDeclName = hsName', hsDeclArgs = hsNames1', 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 (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) subTable = withSrcLoc srcLoc $ do-    hsContext' <- renameHsContext hsContext subTable-    hsNames1' <- renameHsNames hsNames1 subTable-    hsConDecl' <- renameHsConDecl hsConDecl subTable-    return (HsNewTypeDecl srcLoc hsContext' hsName hsNames1' hsConDecl' hsNames2)-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' <- renameHsQualType hsQualType undefined-    hsDecls' <- renameHsDecls hsDecls subTable-    return (HsClassDecl srcLoc hsQualType' hsDecls')-renameHsDecl (HsInstDecl srcLoc hsQualType hsDecls) subTable = withSrcLoc srcLoc $ do-    hsQualType' <- renameHsQualType hsQualType subTable-    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')--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 st) where-    rt :: HsType -> SubTable -> ScopeSM (HsType)-    rt (HsTyFun hsType1 hsType2) subTable = do-        hsType1' <- rt hsType1 subTable-        hsType2' <- rt hsType2 subTable-        return (HsTyFun hsType1' hsType2')-    rt (HsTyTuple hsTypes) subTable = do-        hsTypes' <- mapRename rt hsTypes subTable-        return (HsTyTuple hsTypes')-    rt (HsTyUnboxedTuple hsTypes) subTable = do-        hsTypes' <- mapRename rt hsTypes subTable-        return (HsTyUnboxedTuple hsTypes')-    rt (HsTyApp hsType1 hsType2) subTable = do-        hsType1' <- rt hsType1 subTable-        hsType2' <- rt hsType2 subTable-        return (HsTyApp hsType1' hsType2')-    rt (HsTyVar hsName) subTable | dovar = do-        hsName' <- renameTypeHsName hsName subTable-        return (HsTyVar hsName')-    rt v@(HsTyVar _) _   = return v-    rt (HsTyCon hsName) subTable = do-        hsName' <- renameTypeHsName hsName subTable-        return (HsTyCon hsName')-    rt (HsTyForall ts v) subTable  = do-        v <- renameHsQualType v subTable-        return $ HsTyForall ts v-    rt (HsTyExists ts v) subTable  = do-        v <- renameHsQualType v subTable-        return $ HsTyExists ts v-    rt (HsTyAssoc) subTable = return HsTyAssoc-    rt (HsTyEq a b) subTable = return HsTyEq `ap` (flip rt subTable a) `ap` (flip rt subTable b)-    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 (HsDo hsStmts) subTable = do-    e <- doToExp hsStmts-    renameHsExp e subTable-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')--renameHsGuardedRhss :: HsRhs -> SubTable -> ScopeSM (HsRhs)-renameHsGuardedRhss (HsUnGuardedRhs hsExp) subTable = do-      hsExp' <- renameHsExp hsExp subTable-      return (HsUnGuardedRhs hsExp')-renameHsGuardedRhss (HsGuardedRhss hsGuardedAltList) subTable = do-      hsGuardedAltList' <- renameHsGuardedRhsList hsGuardedAltList subTable-      return (HsGuardedRhss hsGuardedAltList')--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) = concatMap 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) = concatMap getHsNamesFromHsType hsTypes-getHsNamesFromHsType (HsTyUnboxedTuple hsTypes) = concatMap getHsNamesFromHsType hsTypes-getHsNamesFromHsType (HsTyApp hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)-getHsNamesFromHsType (HsTyVar hsName) = [hsName]-getHsNamesFromHsType (HsTyForall vs qt) = getHsNamesFromHsQualType qt List.\\ map hsTyVarBindName vs-getHsNamesFromHsType (HsTyExists vs qt) = getHsNamesFromHsQualType qt List.\\ map hsTyVarBindName vs-getHsNamesFromHsType (HsTyCon _hsName) = [] -- don't rename the Constructors---
− src/FrontEnd/Unlit.hs 
@@ -1,80 +0,0 @@-module FrontEnd.Unlit(unlit) where---- Part of the following code is from--- "Report on the Programming Language Haskell",---   version 1.2, appendix C.---import 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 
@@ -1,54 +0,0 @@--module FrontEnd.Utils where--import 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 { hsDeclName = name } = return (toName TypeConstructor name)-maybeGetDeclName HsNewTypeDecl { hsDeclName = name } = return (toName TypeConstructor name)-maybeGetDeclName (HsClassDecl _ qualType _) = case qualType of-            HsQualType _cntxt t -> return $ leftMostTyCon t-        where-            leftMostTyCon (HsTyTuple ts) = error "lehtMostTyCon applied to tuple" -- toTuple (length ts)-            leftMostTyCon (HsTyApp t1 _) = leftMostTyCon t1-            leftMostTyCon (HsTyVar _) = error "leftMostTyCon: applied to a variable"-            leftMostTyCon (HsTyCon n) = (toName ClassName n)-            leftMostTyCon x = error $ "leftMostTyCon: " ++ show x-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 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 m = vcat [ pprint x <+> text "::" <+> pprint y | (x,y) <- Map.toList m ]--
− src/FrontEnd/Warning.hs 
@@ -1,126 +0,0 @@-module FrontEnd.Warning(-    Warning(..),-    MonadWarn(..),-    processErrors,-    warn,-    warnF,-    err,-    addDiag,-    addWarn,-    processIOErrors,-    printIOErrors-    ) where--import List-import GenUtil-import Options-import System.Exit-import Control.Monad.Writer-import System.IO.Unsafe-import Data.IORef-import Control.Monad.Identity-import FrontEnd.SrcLoc--{-# NOINLINE ioWarnings #-}-ioWarnings :: IORef [Warning]-ioWarnings = unsafePerformIO $ newIORef []---data Warning = Warning { warnSrcLoc :: !SrcLoc, warnType :: String, warnMessage :: String }-    deriving(Eq,Ord)---class Monad m => MonadWarn m where-    addWarning :: Warning -> m ()-    addWarning w = fail $ show w---- If in the IO monad, just show the warning-instance MonadWarn IO where-    addWarning w = modifyIORef ioWarnings (w:)--instance MonadWarn (Writer [Warning]) where-    addWarning w = tell [w]-instance MonadWarn Identity where-    addWarning w = fail $ show w--addWarn t m = do-    sl <- getSrcLoc-    warn sl t m--addDiag s = warn bogusASrcLoc "diagnostic" s-warn s t m = addWarning (Warning { warnSrcLoc = s, warnType = t, warnMessage = m })-err t m = warn bogusASrcLoc t m-warnF fn t m  = warn bogusASrcLoc { srcLocFileName = fn } 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' doDie ws = mapM_ s 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 (fn ++ ": "  ++ msg t m)-    s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l }, warnType = t ,warnMessage = m } =-        putErrLn (fn ++ ":" ++ pad 3 (show l) ++  " - "  ++ msg t m)-    die = (not $ null $ intersect (map warnType ws') fatal) && not (optKeepGoing options)--fatal = [-    "undefined-name",-    "ambiguous-name",-    "multiply-defined",-    "ambiguous-export",-    "unknown-import",-    "parse-error",-    "missing-dep",-    "invalid-decl",-    "invalid-assoc",-    "type-synonym-partialap" ]--ignore = ["h98-emptydata"]--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 } =-         (fn ++ ":" ++ pad 3 (show l) ++  " - "  ++ msg t m)-msg "diagnostic" m = "Diagnostic: " ++ m-msg t m = (if t `elem` fatal 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")-    ]--
− src/GenUtil.hs 
@@ -1,792 +0,0 @@----  $Id: GenUtil.hs,v 1.52 2007/05/25 23:54:08 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, 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,---    -- * Classes-    UniqueProducer(..)-    ) where--import Data.Char(isAlphaNum, isSpace, toLower, ord, chr)-import Data.List-import Control.Monad-import qualified System.IO as IO-import qualified System.IO.Error as IO-import qualified System.Environment as System-import qualified System.Exit as System-import System.Random(StdGen, newStdGen, Random(randomR))-import System.Time-import System.CPUTime--{-# 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] #-}---- | 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 >> System.exitFailure----- | exit program successfully. 'exitFailure' is--- also exported from System.-exitSuccess :: IO a-exitSuccess = System.exitWith System.ExitSuccess---{-# 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 = catch (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 = catch (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 $ System.getEnv s) (\e -> if IO.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)---- | 'concat' composed with 'List.intersperse'. Can be used similarly to join in perl.---intercalate :: [a] -> [[a]] -> [a]---intercalate x xss = concat (intersperse x xss)---- | 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)--{- INLINE foldl' -}--- | strict version of 'foldl'---foldl' :: (a -> b -> a) -> a -> [b] -> a---foldl' _ a []     = a---foldl' f a (x:xs) = (foldl' f $! f a x) xs---- | 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 :: 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 <- System.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 <- System.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 " " [  es n s | s <- xs | n <- cw ]-        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/GhcMain.hs view
@@ -0,0 +1,633 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Main (main) where++import Paths_lhc+import qualified Data.Version as Version+import System.Info+import System.Directory++-- The official GHC API+import qualified GHC+import GHC		( DynFlags(..), HscTarget(..),+                          GhcMode(..), GhcLink(..),+			  LoadHowMuch(..), dopt, DynFlag(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface	( showIface )+import HscMain          ( newHscEnv )+import DriverPipeline	( oneShot, compileFile )+import DriverMkDepend	( doMkDependHS )+#ifdef GHCI+import InteractiveUI	( interactiveUI, ghciWelcomeMsg )+#endif++-- Various other random stuff that we need+import Config+import HscTypes+import Packages		( dumpPackages )+import DriverPhases	( Phase(..), isSourceFilename, anyHsc,+			  startPhase, isHaskellSrcFilename )+import BasicTypes       ( failed )+import StaticFlags+import StaticFlagParser+import DynFlags+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import MonadUtils       ( liftIO )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.List+import Data.Maybe++import Data.Word (Word)+import Foreign.Storable (sizeOf)++import qualified LhcMain as Lhc++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++getLibdir+    = do appdir <- getAppUserDataDirectory "lhc"+         let targetARCH = arch+             targetOS   = os+         let subdir = targetARCH ++ '-':targetOS ++ '-':Version.showVersion version+         return (appdir </> subdir)++main :: IO ()+main = do Lhc.tryMain -- This call will exit if it recognized the command arguments.+          ghcMain++ghcMain :: IO ()+ghcMain = +  GHC.defaultErrorHandler defaultDynFlags $ do+  -- 1. extract the -B flag from the args+  argv0 <- getArgs+  libdir <- getLibdir+  let+        (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+        mbMinusB | null minusB_args = Just libdir+                 | otherwise = Just (drop 2 (last minusB_args))+        wordSize = sizeOf (undefined :: Word)+  let argv1' = map (mkGeneralLocated "on the commandline") ("-fext-core":+                                                            "-no-user-package-conf":+                                                            "-D__LHC__":+                                                            ("-DWORD_SIZE="++show wordSize):+                                                            argv1)+  (argv2, staticFlagWarnings) <- parseStaticFlags argv1'++  -- 2. Parse the "mode" flags (--make, --interactive etc.)+  (m_uber_mode, cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2++  -- If all we want to do is to show the version number then do it+  -- now, before we start a GHC session etc.+  -- If we do it later then bootstrapping gets confused as it tries+  -- to find out what version of GHC it's using before package.conf+  -- exists, so starting the session fails.+  case m_uber_mode of+    -- ShowUsage currently has to be handled specially, as it needs to+    -- actually start up GHC so that it can find the usage.txt files+    -- in the libdir. It would be nice to embed the text in the+    -- executable so that we don't have to do that, and things are more+    -- uniform here.+    Just ShowUsage -> return ()+    Just um ->+        do case um of+               ShowInfo                -> showInfo+               ShowSupportedLanguages  -> showSupportedLanguages+               ShowVersion             -> showVersion+               ShowNumVersion          -> putStrLn (Version.showVersion version)+           exitWith ExitSuccess+    Nothing -> return ()++  -- start our GHC session+  GHC.runGhc mbMinusB $ do++  dflags0 <- GHC.getSessionDynFlags++  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget+  -- can be further adjusted on a module by module basis, using only+  -- the -fvia-C and -fasm flags.  If the default HscTarget is not+  -- HscC or HscAsm, -fvia-C and -fasm have no effect.+  let dflt_target = hscTarget dflags0+      (mode, lang, link)+         = case cli_mode of+        	DoInteractive	-> (CompManager, HscInterpreted, LinkInMemory)+        	DoEval _	-> (CompManager, HscInterpreted, LinkInMemory)+        	DoMake		-> (CompManager, dflt_target,    LinkBinary)+        	DoMkDependHS	-> (MkDepend,    dflt_target,    LinkBinary)+        	_		-> (OneShot,     dflt_target,    LinkBinary)++  let dflags1 = dflags0{ ghcMode   = mode,+                  	 hscTarget = lang,+                         ghcLink   = link,+        		 -- leave out hscOutName for now+                         hscOutName = panic "Main.main:hscOutName not set",+        	  	 verbosity = case cli_mode of+        			 	 DoEval _ -> 0+        			 	 _other   -> 1+        		}++      -- turn on -fimplicit-import-qualified for GHCi now, so that it+      -- can be overriden from the command-line+      dflags1a | DoInteractive <- cli_mode = imp_qual_enabled+               | DoEval _      <- cli_mode = imp_qual_enabled+               | otherwise                 = dflags1+        where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified++        -- The rest of the arguments are "dynamic"+        -- Leftover ones are presumably files+  (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3++  -- As noted earlier, currently we hvae to handle ShowUsage down here+  case m_uber_mode of+      Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode+      _              -> return ()++  let flagWarnings = staticFlagWarnings+                  ++ modeFlagWarnings+                  ++ dynamicFlagWarnings+  liftIO $ handleFlagWarnings dflags2 flagWarnings++        -- make sure we clean up after ourselves+  GHC.defaultCleanupHandler dflags2 $ do++  liftIO $ showBanner cli_mode dflags2++  -- we've finished manipulating the DynFlags, update the session+  GHC.setSessionDynFlags dflags2+  dflags3 <- GHC.getSessionDynFlags+  hsc_env <- GHC.getSession++  let+     -- To simplify the handling of filepaths, we normalise all filepaths right +     -- away - e.g., for win32 platforms, backslashes are converted+     -- into forward slashes.+    normal_fileish_paths = map (normalise . unLoc) fileish_args+    (srcs, objs)         = partition_args normal_fileish_paths [] []++  -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on +  --       the command-line.+  liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)++        ---------------- Display configuration -----------+  when (verbosity dflags3 >= 4) $+        liftIO $ dumpPackages dflags3++  when (verbosity dflags3 >= 3) $ do+        liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)++        ---------------- Final sanity checking -----------+  liftIO $ checkOptions cli_mode dflags3 srcs objs++  ---------------- Do the business -----------+  handleSourceError (\e -> do+       GHC.printExceptionAndWarnings e+       liftIO $ exitWith (ExitFailure 1)) $ do+    case cli_mode of+       PrintLibdir            -> liftIO $ putStrLn (topDir dflags3)+       ShowInterface f        -> liftIO $ doShowIface dflags3 f+       DoMake                 -> doMake srcs+       DoMkDependHS           -> doMkDependHS (map fst srcs)+       StopBefore p           -> oneShot hsc_env p srcs >> GHC.printWarnings+       DoInteractive          -> interactiveUI srcs Nothing+       DoEval exprs           -> interactiveUI srcs $ Just $ reverse exprs++  liftIO $ dumpFinalStats dflags3+  liftIO $ exitWith ExitSuccess++#ifndef GHCI+interactiveUI :: b -> c -> Ghc ()+interactiveUI _ _ =+  ghcError (CmdLineError "not built for interactive use")+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files.  This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+               -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+  | "none" <- suff	= partition_args args srcs objs+  | StopLn <- phase	= partition_args args srcs (slurp ++ objs)+  | otherwise		= partition_args rest (these_srcs ++ srcs) objs+	where phase = startPhase suff+	      (slurp,rest) = break (== "-x") args +	      these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+  | otherwise               = partition_args args srcs (arg:objs)++    {-+      We split out the object files (.o, .dll) and add them+      to v_Ld_inputs for use by the linker.++      The following things should be considered compilation manager inputs:++       - haskell source files (strings ending in .hs, .lhs or other +         haskellish extension),++       - module names (not forgetting hierarchical module names),++       - and finally we consider everything not containing a '.' to be+         a comp manager input, as shorthand for a .hs or .lhs filename.++      Everything else is considered to be a linker object, and passed+      straight through to the linker.+    -}+looks_like_an_input :: String -> Bool+looks_like_an_input m =  isSourceFilename m +		      || looksLikeModuleName m+		      || '.' `notElem` m++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+     -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions cli_mode dflags srcs objs = do+     -- Complain about any unknown flags+   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++   when (notNull (filter isRTSWay (wayNames dflags))+         && isInterpretiveMode cli_mode) $+        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++	-- -prof and --interactive are not a good combination+   when (notNull (filter (not . isRTSWay) (wayNames dflags))+         && isInterpretiveMode cli_mode) $+      do ghcError (UsageError +                   "--interactive can't be used with -prof or -unreg.")+	-- -ohi sanity check+   if (isJust (outputHi dflags) && +      (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))+	then ghcError (UsageError "-ohi can only be used when compiling a single source file")+	else do++	-- -o sanity checking+   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+	 && not (isLinkMode cli_mode))+	then ghcError (UsageError "can't apply -o to multiple source files")+	else do++   let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags)++   when (not_linking && not (null objs)) $+        hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++	-- Check that there are some input files+	-- (except in the interactive case)+   if null srcs && (null objs || not_linking) && needsInputsMode cli_mode+	then ghcError (UsageError "no input files")+	else do++     -- Verify that output files point somewhere sensible.+   verifyOutputFiles dflags+++-- Compiler output options++-- called to verify that the output files & directories+-- point somewhere valid. +--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+-- +verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+  -- not -odir: we create the directory for -odir if it doesn't exist (#2278).+  let ofile = outputFile dflags+  when (isJust ofile) $ do+     let fn = fromJust ofile+     flg <- doesDirNameExist fn+     when (not flg) (nonExistentDir "-o" fn)+  let ohi = outputHi dflags+  when (isJust ohi) $ do+     let hi = fromJust ohi+     flg <- doesDirNameExist hi+     when (not flg) (nonExistentDir "-ohi" hi)+ where+   nonExistentDir flg dir = +     ghcError (CmdLineError ("error: directory portion of " ++ +                             show dir ++ " does not exist (used with " ++ +			     show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++data UberMode+  = ShowUsage               -- ghc -?+  | ShowVersion             -- ghc -V/--version+  | ShowNumVersion          -- ghc --numeric-version+  | ShowSupportedLanguages  -- ghc --supported-languages+  | ShowInfo                -- ghc --info+  deriving (Show)++data CmdLineMode+  = PrintLibdir             -- ghc --print-libdir+  | ShowInterface String    -- ghc --show-iface+  | DoMkDependHS            -- ghc -M+  | StopBefore Phase        -- ghc -E | -C | -S+                            -- StopBefore StopLn is the default+  | DoMake                  -- ghc --make+  | DoInteractive           -- ghc --interactive+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]+  deriving (Show)++#ifdef GHCI+isInteractiveMode :: CmdLineMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _		= False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: CmdLineMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _)    = True+isInterpretiveMode _             = False++needsInputsMode :: CmdLineMode -> Bool+needsInputsMode DoMkDependHS	= True+needsInputsMode (StopBefore _)	= True+needsInputsMode DoMake		= True+needsInputsMode _		= False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: CmdLineMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake	       = True+isLinkMode DoInteractive       = True+isLinkMode (DoEval _)          = True+isLinkMode _   		       = False++isCompManagerMode :: CmdLineMode -> Bool+isCompManagerMode DoMake        = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _)    = True+isCompManagerMode _             = False+++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+               -> IO (Maybe UberMode,+                      CmdLineMode,+                      [Located String],+                      [Located String])+parseModeFlags args = do+  let ((leftover, errs, warns), (mUberMode, mode, _, flags')) =+          runCmdLine (processArgs mode_flags args)+                     (Nothing, StopBefore StopLn, "", [])+  when (not (null errs)) $ ghcError $ errorsToGhcException errs+  return (mUberMode, mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String])+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+  -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+  [  ------- help / version ----------------------------------------------+    Flag "?"                    (NoArg (setUberMode ShowUsage))+         Supported+  , Flag "-help"                (NoArg (setUberMode ShowUsage))+         Supported+  , Flag "V"                    (NoArg (setUberMode ShowVersion))+         Supported+  , Flag "-version"             (NoArg (setUberMode ShowVersion))+         Supported+  , Flag "-numeric-version"     (NoArg (setUberMode ShowNumVersion))+         Supported+  , Flag "-info"                (NoArg (setUberMode ShowInfo))+         Supported+  , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages))+         Supported+  , Flag "-print-libdir"        (PassFlag (setMode PrintLibdir))+         Supported++      ------- interfaces ----------------------------------------------------+  , Flag "-show-iface"  (HasArg (\f -> setMode (ShowInterface f)+                                               "--show-iface"))+         Supported++      ------- primary modes ------------------------------------------------+  , Flag "M"            (PassFlag (setMode DoMkDependHS))+         Supported+  , Flag "E"            (PassFlag (setMode (StopBefore anyHsc)))+         Supported+  , Flag "C"            (PassFlag (\f -> do setMode (StopBefore HCc) f+                                            addFlag "-fvia-C"))+         Supported+  , Flag "S"            (PassFlag (setMode (StopBefore As)))+         Supported+  , Flag "-make"        (PassFlag (setMode DoMake))+         Supported+  , Flag "-interactive" (PassFlag (setMode DoInteractive))+         Supported+  , Flag "e"            (HasArg   (\s -> updateMode (updateDoEval s) "-e"))+         Supported++       -- -fno-code says to stop after Hsc but don't generate any code.+  , Flag "fno-code"     (PassFlag (\f -> do setMode (StopBefore HCc) f+                                            addFlag "-fno-code"+                                            addFlag "-fforce-recomp"))+         Supported+  ]++setUberMode :: UberMode -> ModeM ()+setUberMode m = do+    (_, cmdLineMode, flag, flags') <- getCmdLineState+    putCmdLineState (Just m, cmdLineMode, flag, flags')++setMode :: CmdLineMode -> String -> ModeM ()+setMode m flag = updateMode (\_ -> m) flag++updateDoEval :: String -> CmdLineMode -> CmdLineMode+updateDoEval expr (DoEval exprs) = DoEval (expr : exprs)+updateDoEval expr _              = DoEval [expr]++updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM ()+updateMode f flag = do+  (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState+  if null old_flag || flag == old_flag+      then putCmdLineState (m_uber_mode, f old_mode, flag, flags')+      else ghcError (UsageError+               ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))++addFlag :: String -> ModeM ()+addFlag s = do+  (u, m, f, flags') <- getCmdLineState+  -- XXX Can we get a useful Loc?+  putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags')+++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake []    = ghcError (UsageError "no input files")+doMake srcs  = do+    let (hs_srcs, non_hs_srcs) = partition haskellish srcs++	haskellish (f,Nothing) = +	  looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f+	haskellish (_,Just phase) = +	  phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]++    hsc_env <- GHC.getSession+    o_files <- mapM (\x -> do+                        f <- compileFile hsc_env StopLn x+                        GHC.printWarnings+                        return f)+                 non_hs_srcs+    liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)++    targets <- mapM (uncurry GHC.guessTarget) hs_srcs+    GHC.setTargets targets+    ok_flag <- GHC.load LoadAllTargets++    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+    return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+  hsc_env <- newHscEnv dflags+  showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: CmdLineMode -> DynFlags -> IO ()+showBanner _cli_mode dflags = do+   let verb = verbosity dflags++#ifdef GHCI+   -- Show the GHCi banner+   when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++   -- Display details of the configuration in verbose mode+   when (verb >= 2) $+    do hPutStrLn stderr ("The Luxurious LHC Haskell Optimization System, version " ++ Version.showVersion version)+       hPutStr stderr "Using frontend: Glasgow Haskell Compiler, Version "+       hPutStr stderr cProjectVersion+       hPutStr stderr ", for Haskell 98, stage "+       hPutStr stderr cStage+       hPutStr stderr " booted by GHC version "+       hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: IO ()+showInfo = do+    let sq x = " [" ++ x ++ "\n ]"+    putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo+    exitWith ExitSuccess++showSupportedLanguages :: IO ()+showSupportedLanguages = do mapM_ putStrLn supportedLanguages+                            exitWith ExitSuccess++showVersion :: IO ()+showVersion = do+  putStrLn ("The Luxurious LHC Haskell Optimization System, version " ++ Version.showVersion version)+  putStrLn ("Using frontend: " ++ cProjectName ++ ", version " ++ cProjectVersion)+  exitWith ExitSuccess++showGhcUsage :: DynFlags -> CmdLineMode -> IO ()+showGhcUsage dflags cli_mode = do +  let usage_path +	| DoInteractive <- cli_mode = ghciUsagePath dflags+	| otherwise		    = ghcUsagePath dflags+  usage <- readFile usage_path+  dump usage+  exitWith ExitSuccess+  where+     dump ""	      = return ()+     dump ('$':'$':s) = putStr progName >> dump s+     dump (c:s)	      = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags = +  when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+  buckets <- getFastStringTable+  let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets+      msg = text "FastString stats:" $$+	    nest 4 (vcat [text "size:           " <+> int (length buckets),+			  text "entries:        " <+> int entries,+			  text "longest chain:  " <+> int longest,+			  text "z-encoded:      " <+> (is_z `pcntOf` entries),+			  text "has z-encoding: " <+> (has_z `pcntOf` entries)+			 ])+	-- we usually get more "has z-encoding" than "z-encoded", because+	-- when we z-encode a string it might hash to the exact same string,+	-- which will is not counted as "z-encoded".  Only strings whose+	-- Z-encoding is different from the original string are counted in+	-- the "z-encoded" total.+  putMsg dflags msg+  where+   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'++countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)+countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)+countFS entries longest is_z has_z (b:bs) = +  let+	len = length b+	longest' = max len longest+	entries' = entries + len+	is_zs = length (filter isZEncoded b)+	has_zs = length (filter hasZEncoding b)+  in+	countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))
− src/Grin/Arity.hs 
@@ -1,49 +0,0 @@-module Grin.Arity(grinRaiseArity) where--import IO(stdout)-import qualified Data.Map as Map--import Fixer.Fixer-import Fixer.Supply-import Grin.Grin-import Support.ShowTable-import Support.FreeVars-import GenUtil---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 
@@ -1,207 +0,0 @@-module Grin.DeadCode(deadCode) where---import Data.Monoid-import Monad-import qualified Data.Set as Set-import qualified Data.Map as Map--import StringTable.Atom-import Fixer.Fixer-import Fixer.Supply-import Grin.Grin-import Grin.Noodle-import Grin.Whiz-import Stats hiding(print)-import Support.CanType-import Support.FreeVars-import Util.Gen---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 :: IO (Supply Atom Bool)-    usedArgs <- newSupply fixer  :: IO (Supply (Tag, Int) Bool)-    usedCafs <- newSupply fixer  :: IO (Supply Var Bool)-    pappFuncs <- newValue fixer bottom :: IO (Value (Set.Set Tag))-    suspFuncs <- newValue fixer bottom :: IO (Value (Set.Set Tag))-    -- set all roots as used-    flip mapM_ roots $ \r -> do-        addRule $ value True `implies` sValue usedFuncs r-    let postInline = phaseEvalInlined (grinPhase grin)---    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 -                 `Set.union`-                 Set.fromList [ (n,i) | FuncDef n (args :-> _) _ _ <- grinFunctions grin,-                                        n `Map.member` grinEntryPoints grin,-                                        i <- [0 .. length args] ]-        directFuncs =  funSet Set.\\ suspFuncs Set.\\ pappFuncs-        fg xs = Set.fromList [ x | (x,True) <- xs ]-    newCafs <- flip mconcatMapM (grinCafs grin) $ \ (x,y) -> if x `Set.member` cafSet then return [(x,y)] else tick stats "Optimize.dead-code.caf" >> return []-    newFuncs <- flip mconcatMapM (grinFuncs grin) $ \ (x,y) -> do-        if not $ x `Set.member` funSet then tick stats "Optimize.dead-code.func" >> return [] else do-        r <- runStatIO stats $ removeDeadArgs postInline funSet directFuncs cafSet argSet (x,y)-        return [r]-    let (TyEnv mp) = grinTypeEnv grin-    mp' <- flip mconcatMapM (Map.toList mp) $ \ (x,tyty@TyTy { tySlots = ts }) -> case Just x  of-        Just _ | tagIsFunction x, not $ x `Set.member` funSet -> return []-        Just fn | fn `Set.member` directFuncs -> do-            let da (t,i)-                    | Set.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 $ Map.fromList mp',-        --grinArgTags = Map.fromList newArgTags,-        grinSuspFunctions = suspFuncs-        }--combineArgs fn as = [ ((fn,n),a) | (n,a) <- zip [0 :: Int ..] as]--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 (App a [e] _)   | a == funcEval =  addRule (doNode e)-            g (App a [x,y] _) | a == funcApply =  addRule (doNode x `mappend` doNode y)-            g (App a [x] _)   | a == funcApply =  addRule (doNode x)-            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 doConst vs)-            g (Update (Var v _) n) | v < v0 = do-                v' <- supplyValue usedCafs v-                addRule $ conditionalRule id v' $ doNode n-            g (Update vv@(Index (Var v _) r) n) | v < v0 = do-                v' <- supplyValue usedCafs v-                addRule (doNode r)-                addRule $ conditionalRule id v' $ doNode n-            g (Update vv n) = addRule $ (doNode vv) `mappend` (doNode n)-            g (Store n) = addRule $ doNode n-            g (Fetch x) = addRule $ doNode x-            g Alloc { expValue = v, expCount = c, expRegion = r } = addRule $ doNode v `mappend` doNode c `mappend` doNode r-            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,Store 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,Fetch v)) vs -- addRule $ mconcat $ [ conditionalRule id  (varValue pv) (doNode v) | pv <- freeVars p]-            h (p,Fetch 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 doConst as)-                usedfn = fn' `implies` sValue usedFuncs fn-                suspfn | x > 0 = conditionalRule id fn' (pappFuncs `isSuperSetOf` value (Set.singleton fn))-                       | otherwise = conditionalRule id fn' (suspFuncs `isSuperSetOf` value (Set.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 (Tup ns) = mconcatMap doConst ns-            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) -> m (Atom,Lam)-removeDeadArgs postInline funSet directFuncs usedCafs usedArgs (a,l) =  whizExps f (margs a l) >>= return . (,) a where-    margs fn (as :-> e) | a `Set.member` directFuncs = ((removeArgs fn as) :-> e)-    margs _ x = x-    f (App fn as ty) | fn `notElem` [funcApply, funcEval] = 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 (Store (NodeC fn as)) |  Just fn' <- tagToFunction fn = do-        as <- dff' fn' as-        as <- mapM clearCaf as-        return $ Store (NodeC fn as)-    f (Update (Var v (TyPtr TyNode)) _) | 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 `Set.member` directFuncs = return as-    dff' fn as = dff'' fn as-    dff fn as | fn `Set.member` directFuncs = return (removeArgs fn as)-    dff fn as = dff'' fn as-    dff'' fn as | not (fn `Set.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 (Set.member (fn,i) usedArgs) = do-            mtick $ toAtom "Optimize.dead-code.func-arg"-            return $ properHole (getType a)-        df (a,_)  = return a-    clearCaf (Var v (TyPtr TyNode)) | deadCaf v = do-        mtick $ toAtom "Optimize.dead-code.caf-arg"-        return (properHole (TyPtr TyNode))-    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 `Set.member` usedCafs)-    deadVal (Lit 0 _) = True-    deadVal x = isHole x-    removeArgs fn as = concat [ perhapsM ((fn,i) `Set.member` usedArgs) a | a <- as | i <- naturals ]--
− src/Grin/Devolve.hs 
@@ -1,122 +0,0 @@-module Grin.Devolve(twiddleGrin,devolveTransform,devolveGrin) where--import Control.Monad.Identity-import Control.Monad.RWS-import Data.IORef-import qualified Data.Map as Map-import qualified Data.Set as Set--import Util.Gen-import Support.Transform-import Grin.Grin-import Grin.Noodle-import Support.FreeVars-import Options (verbose)--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 nonTail = expNonNormal lt-                (nmaps,rmaps) = splitEither (map z defs)-                z fd@FuncDef { funcDefName = name, funcDefBody = as :-> r }-                    | name `Set.member` nonTail = Left ((name,(as ++ xs) :-> proc r),xs)-                    | otherwise = Right fd { funcDefBody = as :-> proc r }-                  where xs = [ Var v t |  (v,t) <- Set.toList $ freeVars (as :-> r), v > v0]-                pmap = Map.fromList [ (n,xs) | ((n,_),xs) <- nmaps]-                proc b = runIdentity (proc' b)-                proc' (App a as t) | Just xs <- Map.lookup a pmap = return (App a (as ++ xs) t)-                proc' e = mapExpExp proc' e-            mapM_ print (Map.toList pmap)-            nmaps <- mapM (g . fst) nmaps-            modifyIORef col (++ nmaps)-            mapExpExp f $  updateLetProps lt { expDefs = rmaps, expBody = 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 }---data Env = Env {-    envMap :: Map.Map Var Var,-    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 { 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 (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 n = do e <- mapExpVal twiddleVal n ; mapExpExp twiddle e--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 
@@ -1,137 +0,0 @@-module Grin.Embed((.>>=),(.>>),GG,VVar,TyNode,TyTag,TyPtr,TyRaw,embedTest) where--import Grin.Grin-import Util.UniqueMonad-import Support.CanType-import StringTable.Atom-import GenUtil-import Grin.Show-import Doc.Pretty---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/Eval/Compile.hs view
@@ -0,0 +1,161 @@+-- Run-time compilation of GRIN.+-- Note: This is only a more efficient way of interpreting GRIN.+module Grin.Eval.Compile+    ( runGrin+    ) where++import Grin.Types hiding (Value(..))+import qualified Grin.Types as Grin+import Grin.Eval.Types+import Grin.Eval.Primitives+import Grin.Eval.Methods++import qualified Data.Map as Map+import Control.Monad.Reader++import CompactString+import Grin.Types hiding (Value(..))++import qualified Data.Map as Map+import Control.Monad.State+import Data.Char+import Data.IORef; import System.IO.Unsafe++++runGrin :: Grin -> String -> [String] -> IO EvalValue+runGrin grin entry commandArgs+    = let globalScope = GlobalScope { globalCAFs  = Map.fromList cafs+                                    , globalFuncs = Map.fromList (funcs ++ prims) }+          cafs = zip (map cafName (grinCAFs grin)) [0..]+          funcs = [ (funcDefName def, compFuncDef def globalScope) | def <- grinFunctions grin ]+          prims = listPrimitives globalScope+          apply = lookupFunction (Builtin $ fromString "evalApply") globalScope+      in runComp $ do mapM_ storeValue =<< mapM (\caf -> compValue (cafValue caf) globalScope) (grinCAFs grin)+                      setCommandArgs ("lhc":commandArgs)+                      entry <- lookupVariable renamedEntry globalScope+                      apply [entry, realWorld]+    where renamedEntry = case [ cafName caf | caf <- grinCAFs grin, Just name <- [alias (cafName caf)], name == fromString entry ] of+                           []       -> error $ "Grin.Eval.Basic.evaluate: couldn't find entry point: " ++ entry+                           (name:_) -> name++runComp comp+    = runReaderT (evalStateT (unComp comp) initState) Map.empty+    where initState = EvalState { stateHeap = Map.empty+                                , stateFree = 0+                                , stateArgs = ["lhc"] }++{-# NOINLINE indent #-}+indent :: IORef Int+indent = unsafePerformIO (newIORef 0)++withIndent str fn+    = do n <- liftIO $ readIORef indent+         liftIO $ putStrLn $ replicate n ' ' ++ str+         liftIO $ writeIORef indent (n+2)+         ret <- fn+         liftIO $ writeIORef indent n+         return ret++compFuncDef :: FuncDef -> Gen CompFunction+compFuncDef func+    = do exp <- compExpression (funcDefBody func)+         return $ \args -> local (const $ Map.fromList (zip (funcDefArgs func) args)) exp++compExpression :: Expression -> Gen CompExpression+compExpression (e :>> l)+    = do e' <- compExpression e+         l' <- compExpression l+         return $ e' >> l'+compExpression (e :>>= v :-> l)+    = do e' <- compExpression e+         l' <- compExpression l+         return $ do val <- e'+                     local (Map.insert v val) l'+compExpression (Application (External name) args)+    = runExternal name =<< mapM lookupVariable args+compExpression (Application name args)+    = do fn <- lookupFunction name+         args' <- mapM lookupVariable args+         return $ do args'' <- mapM id args'+                     --withIndent ("Running: " ++ show name ++ " " ++ show args ++ " " ++ show args'') $+                     fn args''+compExpression (Unit value)+    = compValue value+compExpression (Store val)+    = do val' <- compValue val+         return $ do ptr <- storeValue =<< val'+                     return $ HeapPointer ptr+compExpression (Case val alts)+    = do val' <- lookupVariable val+         let (binds,cases) = unzip [ (b,c) | b :> c <- alts ]+         cases' <- mapM compExpression cases+         return $ do val'' <- val'+                     --liftIO $ putStrLn $ "case expression: " ++ show (val,val'')+                     runCase val'' (zip binds cases')++compValue :: Grin.Value -> Gen CompValue+compValue (Grin.Node name Grin.ConstructorNode n args)+    = do args' <- mapM lookupVariable args+         return $ do args'' <- mapM id args'+                     return $ CNode name n args''+compValue (Grin.Node name Grin.FunctionNode n args)+    = do fn <- lookupFunction name+         args' <- mapM lookupVariable args+         return $ do args'' <- mapM id args'+                     return $ FNode name fn n args''+compValue (Grin.Variable v) = lookupVariable v+compValue Grin.Empty        = return $ return Empty+compValue (Grin.Lit lit)    = return $ return $ Lit lit+compValue (Grin.Hole size)  = return $ return $ Hole size+compValue (Grin.Vector vs)+    = do vs' <- mapM lookupVariable vs+         return $ do vs'' <- mapM id vs'+                     return $ Vector vs''++runCase :: EvalValue -> [(Grin.Value, CompValue)] -> CompValue+runCase val cases+    = worker cases+    where worker (x@(Grin.Variable{}, e) : y : ys)+              = worker (y:x:ys)+          worker [(Grin.Variable name, e)]+              = local (Map.insert name val) e+          worker ((b,c):xs)+              = case doesMatch val b of+                  Nothing -> worker xs+                  Just fn -> fn c+          worker [] = error $ "runCase: " ++ show (val, map fst cases)++doesMatch :: EvalValue -> Grin.Value -> Maybe (CompValue -> CompValue)+doesMatch val (Grin.Variable var)+    = Just $ local (Map.insert var val)+doesMatch (CNode tag _ args) (Grin.Node bTag _ _ bArgs) | tag == bTag && length args == length bArgs+    = bindLambdas (zip args $ map Grin.Variable bArgs)+doesMatch (Vector vs1) (Grin.Vector vs2) | length vs1 == length vs2+    = bindLambdas (zip vs1 $ map Grin.Variable vs2)+doesMatch (Lit litA) (Grin.Lit litB) | litA == litB+    = Just id+doesMatch (FNode name fn arity args) (Grin.Node tag FunctionNode n args') | name == tag && arity == n+    = bindLambdas (zip args $ map Grin.Variable args')+doesMatch _ Grin.Empty+    = Just id+doesMatch from to+    = Nothing+++bindLambda :: EvalValue -> Grin.Value -> CompValue -> CompValue+bindLambda from to+    = case doesMatch from to of+        Nothing -> error $ "bindLambda: " ++ show (from, to)+        Just fn -> fn++bindLambdas :: [(EvalValue, Grin.Value)] -> Maybe (CompValue -> CompValue)+bindLambdas [] = Just id+bindLambdas ((a,b):xs)+    = case (doesMatch a b, bindLambdas xs) of+        (Just fn, Just fn') -> Just (fn . fn')+        _                   -> Nothing++++
+ src/Grin/Eval/Methods.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Grin.Eval.Methods where++import CompactString+import Grin.Types hiding (Value)+import qualified Grin.Types as Grin+import Grin.Eval.Types++import qualified Data.Map as Map+import Control.Monad.State+import Control.Monad.Reader+import Control.Exception+import Data.Typeable+import Prelude hiding (catch)++data GrinException = GrinException EvalState HeapPointer deriving (Typeable,Show)+instance Exception GrinException+++setCommandArgs :: [String] -> Comp ()+setCommandArgs args = modify $ \st -> st{stateArgs = args}++getCommandArgs :: Comp [String]+getCommandArgs = gets stateArgs+++lookupFunction :: Renamed -> Gen CompFunction+lookupFunction name globalScope+    = case Map.lookup name (globalFuncs globalScope) of+        Just fn -> fn+        Nothing -> error $ "Grin.Eval.Compile.lookupFunction: Couldn't find function: " ++ show name++fetch :: HeapPointer -> CompValue+fetch ptr+    = gets $ \st -> Map.findWithDefault errMsg ptr (stateHeap st)+    where errMsg = error $ "Grin.Eval.Compile.fetch: couldn't find heap value for: " ++ show ptr++storeValue :: EvalValue -> Comp HeapPointer+storeValue val+    = do st <- get+         let newFree = stateFree st + 1+         put st{stateFree = newFree+                  ,stateHeap = Map.insert (stateFree st) val (stateHeap st)}+         --liftIO $ putStrLn $ "Store value: " ++ unwords [show (stateFree st), show val]+         return (stateFree st)++updateValue :: HeapPointer -> EvalValue -> Comp ()+updateValue ptr val+    = modify $ \st -> st{stateHeap = Map.alter fn ptr (stateHeap st)}+    where fn _ = Just val+++lookupVariable :: Renamed -> Gen CompValue+lookupVariable var globalScope+    = case Map.lookup var (globalCAFs globalScope) of+        Just caf -> return $ HeapPointer caf+        Nothing  -> asks (Map.findWithDefault errMsg var)+    where errMsg = error $ "Grin.Compile.RunTime.lookupVariable: couldn't find variable: " ++ show var++catchComp :: Comp a -> (EvalValue ->Comp a) -> Comp a+catchComp fn handler+    = CompExpression $ StateT $ \st -> ReaderT $ \r -> runReaderT (runStateT (unComp fn) st) r `catch` \(GrinException st' ptr) ->+                                                       runReaderT (runStateT (unComp (handler (HeapPointer ptr))) st') r
+ src/Grin/Eval/Primitives.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Grin.Eval.Primitives+    ( runExternal+    , listPrimitives+    , realWorld+    ) where++import Grin.Types hiding (Value(..))+import qualified Grin.Types as Grin++import qualified Data.Map as Map++import CompactString+import Grin.Types hiding (Value(..))+import Grin.Eval.Types++import qualified Data.Map as Map+import Control.Monad.State+import Control.Exception+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.C+import Foreign.Storable+import Data.Char; import Data.Word; import Data.Bits; import Data.Int++import Foreign.Marshal (copyBytes, newArray)+import System.Posix (fdWrite,Fd(..))+import System.Posix.DynamicLinker+import Foreign.LibFFI++import Grin.Eval.Methods++-- These functions are defined in the base library. I'm not sure how to deal with this properly.+runExternal :: String -> [CompValue] -> Gen CompValue+runExternal name args+    = do let returnIO v = return (Vector [realWorld, v])+         return $+            do args' <- mapM id args+               case (name, init args') of+                 ("__hscore_memcpy_dst_off", [Lit (Lint dst),Lit (Lint off),Lit (Lint src),Lit (Lint size)]) ->+                   do let dstPtr = nullPtr `plusPtr` fromIntegral (dst+off)+                          srcPtr = nullPtr `plusPtr` fromIntegral src+                      liftIO $ copyBytes dstPtr srcPtr (fromIntegral size)+                      returnIO (Lit (Lint (dst+off)))+                 ("__hscore_PrelHandle_write", [Lit (Lint fd),Lit (Lint ptr),Lit (Lint offset),Lit (Lint size)]) ->+                   do let strPtr = nullPtr `plusPtr` fromIntegral (ptr+offset)+                      str <- liftIO $ peekCStringLen (strPtr,fromIntegral size)+                      out <- liftIO $ fdWrite (Fd (fromIntegral fd)) str+                      returnIO (Lit (Lint $ fromIntegral out))+                 ("__hscore_get_errno", []) ->+                   returnIO (Lit (Lint 0))+                 ("__hscore_bufsiz", []) ->+                   returnIO (Lit (Lint 512))+                 ("fdReady", [fd,write,msecs,isSock]) ->+                   returnIO (Lit (Lint 1))+                 ("rtsSupportsBoundThreads", []) ->+                   returnIO (Lit (Lint 1))+                 ("stg_sig_install", [signo, actioncode, ptr]) ->+                   returnIO (Lit (Lint 0))+                 ("getProgArgv", [Lit (Lint argcPtr), Lit (Lint argvPtr)]) ->+                   do args <- getCommandArgs+                      liftIO $ poke (nullPtr `plusPtr` fromIntegral argcPtr) (fromIntegral (length args) :: CInt)+                      cs <- liftIO $ newArray =<< mapM newCString args+                      liftIO $ poke (nullPtr `plusPtr` fromIntegral argvPtr) cs+                      return $ Vector [Empty]+                 ("u_iswlower", [Lit (Lint ch)]) ->+                   do returnIO $ Lit (Lint (fromIntegral (fromEnum (isLower (chr (fromIntegral ch))))))+                 ("u_iswalpha", [Lit (Lint ch)]) ->+                   do returnIO $ Lit (Lint (fromIntegral (fromEnum (isAlpha (chr (fromIntegral ch))))))+                 ("u_iswspace", [Lit (Lint ch)]) ->+                   do returnIO $ Lit (Lint (fromIntegral (fromEnum (isSpace (chr (fromIntegral ch))))))+                 (name, args) ->+                   -- If we don't recognize the function, try loading it through the linker.+                   do fnPtr <- liftIO $ dlsym Default name+                      let toCArg (Lit (Lint i)) = argCInt (fromIntegral i)+                      ret <- liftIO $ callFFI fnPtr retCInt (map toCArg args)+                      returnIO $ Lit (Lint (fromIntegral ret))++++++++newtype IntArg = IntArg Int+newtype CharArg = CharArg Char+newtype ArrayArg = ArrayArg [EvalValue]+newtype AnyArg = AnyArg EvalValue+newtype PtrArg = PtrArg (Ptr ())+newtype HeapArg = HeapArg HeapPointer+data RealWorld = RealWorld++data Primitive = Primitive { primName :: String, primHandle :: ([EvalValue] -> CompExpression) }+++-- Primitive handlers++listPrimitives :: GlobalScope -> [(Renamed, CompFunction)]+listPrimitives globalScope+    = [ (Builtin name, primHandle (prim globalScope)) | (name, prim) <- Map.toList allPrimitives ]++allPrimitives :: Map.Map CompactString (GlobalScope -> Primitive)+allPrimitives = Map.fromList [ (fromString name, prim) | (name, prim) <- prims ]+    where prims = [ equal, gt, lt, gte, lte+                  , chrPrim, ordPrim+                  , plus, plusWord, minus, minusWord, times, timesWord, remInt, quotInt, addIntC+                  , indexCharOffAddr+                  , readInt32OffAddr, readInt8OffAddr, readAddrOffAddr+                  , writeInt8OffAddr+                  , writeCharArray+                  , touch, makeStablePtr, writeStablePtrOffAddr+                  , noDuplicate+                  , realWorldPrim, myThreadIdPrim, raisePrim+                  , catchPrim, blockAsyncExceptions, unblockAsyncExceptions+                  , newPinnedByteArray, newAlignedPinnedByteArray+                  , unsafeFreezeByteArray, byteArrayContents+                  , updatePrim, fetchPrim, evalPrim, evalApplyPrim, applyPrim+                  , newArrayPrim, readArray, writeArray+                  , narrow8Word, narrow8Int, narrow16Word, narrow16Int, narrow32Int, negateInt+                  , narrow32Word+                  , mkWeak]++++-- Primitive definitions++-- FIXME: Throw an error when values of different types are compared.+equal = mkPrimitive "==#" $ binOp (==)+gt    = mkPrimitive ">#" $ binOp (>)+lt    = mkPrimitive "<#" $ binOp (<)+gte   = mkPrimitive ">=#" $ binOp (>=)+lte   = mkPrimitive "<=#" $ binOp (<=)++plus = mkPrimitive "+#" $ binIntOp (+)+plusWord = mkPrimitive "plusWord#" $ binIntOp (+)+minus = mkPrimitive "-#" $ binIntOp (-)+minusWord = mkPrimitive "minusWord#" $ binIntOp (-)+times = mkPrimitive "*#" $ binIntOp (*)+timesWord = mkPrimitive "timesWord#" $ binIntOp (*)+remInt = mkPrimitive "remInt#" $ binIntOp rem+quotInt = mkPrimitive "quotInt#" $ binIntOp quot++chrPrim = mkPrimitive "chr#" $ return $ \(CharArg c) -> noScope $ return (Lit (Lchar c))+ordPrim = mkPrimitive "ord#" $ return $ \(IntArg i) -> noScope $ return (Lit (Lint $ fromIntegral i))++addIntC = mkPrimitive "addIntC#" $+             return $ \(IntArg a) (IntArg b) ->+                let c = fromIntegral a + fromIntegral b+                    o = c `shiftR` bitSize (0::Int)+                in noScope $ return (Vector [Lit (Lint c), Lit (Lint o)])++-- |Reads 8-bit character; offset in bytes.+indexCharOffAddr+    = mkPrimitive "indexCharOffAddr#" $+      return $ \(PtrArg ptr) (IntArg nth) ->+                 noScope $ do c <- peekByteOff ptr nth :: IO Word8+                              return (Lit (Lchar (chr (fromIntegral (c::Word8)))))++readInt32OffAddr+    = mkPrimitive "readInt32OffAddr#" $+      return $ \(PtrArg ptr) (IntArg nth) RealWorld ->+           noScope $ do i <- peekElemOff (castPtr ptr) nth+                        return (Vector [realWorld, fromInt (fromIntegral (i::Int32))])++readInt8OffAddr+    = mkPrimitive "readInt8OffAddr#" $+         return $ \(PtrArg ptr) (IntArg nth) RealWorld ->+                   noScope $ do i <-  peekElemOff (castPtr ptr) nth+                                return $ Vector [realWorld, fromInt (fromIntegral (i::Int8))]++writeInt8OffAddr+    = mkPrimitive "writeInt8OffAddr#" $+      return $ \(PtrArg ptr) (IntArg nth) (IntArg elt) RealWorld ->+               noScope $ do poke (ptr `plusPtr` nth) (fromIntegral elt :: Word8)+                            return realWorld++readAddrOffAddr+    = mkPrimitive "readAddrOffAddr#" $+         return $ \(PtrArg ptr) (IntArg nth) RealWorld ->+                    noScope $ do p <- peekElemOff (castPtr ptr) nth+                                 return $ Vector [realWorld, fromPointer p]++-- |Write 8-bit character; offset in bytes.+writeCharArray+    = mkPrimitive "writeCharArray#" $+         return $ \(PtrArg ptr) (IntArg offset) (CharArg c) RealWorld ->+                    noScope $ do poke (ptr `plusPtr` offset) (fromIntegral (ord c) :: Word8)+                                 return realWorld++touch+    = mkPrimitive "touch#" $ return $ \(AnyArg _) RealWorld ->+      noScope $ return realWorld++makeStablePtr+    = mkPrimitive "makeStablePtr#" $ return $ \(AnyArg a) RealWorld ->+      noScope $ return $ Vector [realWorld, Lit (Lstring "stable pointer")]++writeStablePtrOffAddr+    = mkPrimitive "writeStablePtrOffAddr#" $ return $ \(PtrArg p) (IntArg n) (AnyArg stablePtr) RealWorld ->+      noScope $ return realWorld++noDuplicate = mkPrimitive "noDuplicate#" $ return $ \RealWorld -> noScope $ return realWorld++realWorldPrim = mkPrimitive "realWorld#" $ return $ noScope $ return realWorld++myThreadIdPrim+    = mkPrimitive "myThreadId#" $+         return $ \RealWorld ->+                     noScope $ return (Vector [realWorld, Lit (Lint 0)])++raisePrim+    = mkPrimitive "raise#" $+      return $ \(HeapArg ptr) ->+               do st <- get+                  liftIO $ throwIO (GrinException st ptr) :: CompValue++catchPrim+    = mkPrimitive "catch#" $+      do evalApply <- lookupFunction (Builtin $ fromString "evalApply")+         apply <- lookupFunction (Builtin $ fromString "apply")+         return $ \(AnyArg fn) (AnyArg handler) RealWorld ->+                  evalApply [fn, realWorld]+{- `catchComp` \val ->+                  do v <- evalApply [handler, val]+                     apply [v, realWorld]-}++blockAsyncExceptions+    = mkPrimitive "blockAsyncExceptions#" $+      do apply <- lookupFunction (Builtin $ fromString "evalApply")+         return $ \(AnyArg fn) RealWorld ->+                     apply [fn,realWorld]++unblockAsyncExceptions+    = mkPrimitive "unblockAsyncExceptions#" $+      do apply <- lookupFunction (Builtin $ fromString "evalApply")+         return $ \(AnyArg fn) RealWorld ->+                     apply [fn, realWorld]++-- |Create a mutable byte array that the GC guarantees not to move.+newPinnedByteArray+    = mkPrimitive "newPinnedByteArray#" $+         return $ \(IntArg size) RealWorld ->+                    noScope $ do ptr <- mallocBytes size+                                 return (Vector [realWorld, fromPointer ptr])++newAlignedPinnedByteArray+    = mkPrimitive "newAlignedPinnedByteArray#" $+         return $ \(IntArg size) (IntArg alignment) RealWorld ->+                    noScope $ do ptr <- mallocBytes (size + alignment)+                                 return (Vector [realWorld, fromPointer $ alignPtr ptr alignment])++unsafeFreezeByteArray+    = mkPrimitive "unsafeFreezeByteArray#" $+         return $ \(PtrArg ptr) RealWorld ->+                     noScope $ return (Vector [realWorld, fromPointer ptr])++byteArrayContents+    = mkPrimitive "byteArrayContents#" $ return $ \(PtrArg ptr) ->+      noScope $ return (fromPointer ptr)++updatePrim+    = mkPrimitive "update" $ return $ \(HeapArg ptr) (AnyArg val) ->+      do updateValue ptr val+         return Empty++fetchPrim+    = mkPrimitive "fetch" $ return $ \(HeapArg ptr) ->+      do fetch ptr++evalPrim+    = mkPrimitive "eval" $ return $ \(AnyArg arg) ->+      runEvalPrimitive arg++evalApplyPrim+    = mkPrimitive "evalApply" $ return $ \(AnyArg fnPtr) (AnyArg arg) ->+      do fn <- runEvalPrimitive fnPtr+         case fn of+              FNode name fn 1 args -> fn (args ++ [arg])+              FNode name fn 0 args -> error "apply: over application?"+              FNode name fn n args -> return $ FNode name fn (n-1) (args ++ [arg])+              CNode name 0 args -> error "apply: over application?"+              CNode name n args -> return $ CNode name (n-1) (args ++ [arg])+              _ -> error $ "weird apply: " ++ show fn++applyPrim+    = mkPrimitive "apply" $ return $ \(AnyArg fn) (AnyArg arg) ->+      do case fn of+           FNode name fn 1 args -> fn (args ++ [arg])+           FNode name fn 0 args -> error "apply: over application?"+           FNode name fn n args -> return $ FNode name fn (n-1) (args ++ [arg])+           CNode name 0 args -> error "apply: over application?"+           CNode name n args -> return $ CNode name (n-1) (args ++ [arg])+           _ -> error $ "weird apply: " ++ show fn++newArrayPrim+    = mkPrimitive "newArray#" $+         return $ \(IntArg len) (AnyArg elt) RealWorld ->+                    do ptr <- storeValue (Array $ replicate len elt)+                       return $ Vector [realWorld, HeapPointer ptr]++readArray+    = mkPrimitive "readArray#" $+         return $ \(HeapArg ptr) (IntArg idx) RealWorld ->+                    do Array arr <- fetch ptr+                       return $ Vector [realWorld, arr!!idx]++writeArray+    = mkPrimitive "writeArray#" $ return $ \(HeapArg ptr) (IntArg idx) (AnyArg val) RealWorld ->+      do Array arr <- fetch ptr+         let (before,after) = splitAt idx arr+         updateValue ptr (Array (before ++ [val] ++ drop 1 after))+         return realWorld++-- |Create @MutVar\#@ with specified initial value in specified state thread.+{-+newMutVar+    = mkPrimitive "newMutVar#" $+         return $ \(AnyArg val) RealWorld ->+                    do ptr <- storeValue val+                       return $ Vector [realWorld, HeapPointer ptr]++-- |Write contents of @MutVar\#@.+writeMutVar+    = mkPrimitive "writeMutVar#" $ return $ \(HeapArg ptr) (AnyArg val) RealWorld ->+      do updateValue ptr val+         return realWorld++-- |Read contents of @MutVar\#@. Result is not yet evaluated.+readMutVar+    = mkPrimitive "readMutVar#" $+         return $ \(HeapArg ptr) RealWorld ->+                  do val <- fetch ptr+                     return (Vector [realWorld, val])+-}+-- Dummy primitive+mkWeak = mkPrimitive "mkWeak#" $+            return $ \(AnyArg key) (AnyArg val) (AnyArg finalizer) RealWorld ->+                       noScope $ return (Vector [realWorld, Empty])++fromInt32 i = fromInt (fromIntegral (fromIntegral i::Int32)::Int)+fromWord32 i = fromInt (fromIntegral (fromIntegral i::Word32)::Int)+fromInt16 i = fromInt (fromIntegral (fromIntegral i::Int16)::Int)+fromWord16 i = fromInt (fromIntegral (fromIntegral i::Word16)::Int)+fromInt8 i = fromInt (fromIntegral (fromIntegral i::Int8)::Int)+fromWord8 i = fromInt (fromIntegral (fromIntegral i::Word8)::Int)++narrow32Int+    = mkPrimitive "narrow32Int#" $ return $ \(IntArg i) -> noScope $ return (fromInt32 i)+narrow32Word+    = mkPrimitive "narrow32Word#" $ return $ \(IntArg i) -> noScope $ return (fromWord32 i)++narrow16Int+    = mkPrimitive "narrow16Int#" $ return $ \(IntArg i) -> noScope $ return (fromInt16 i)+narrow16Word+    = mkPrimitive "narrow16Word#" $ return $ \(IntArg i) -> noScope $ return (fromWord16 i)++narrow8Word+    = mkPrimitive "narrow8Word#" $ return $ \(IntArg i) -> noScope $ return (fromInt8 i)+narrow8Int+    = mkPrimitive "narrow8Int#" $ return $ \(IntArg i) -> noScope $ return (fromWord8 i)++negateInt+    = mkPrimitive "negateInt#" $ return $ \(IntArg i) -> noScope $ return (fromInt (negate i))++++++-- Primitive helpers+++noScope :: IO EvalValue -> CompValue+noScope = liftIO+++runEvalPrimitive :: EvalValue -> CompValue+runEvalPrimitive (HeapPointer ptr)+    = worker =<< fetch ptr+    where worker orig@(FNode name fn 0 args)+              = do --liftIO $ putStrLn $ "Running: " ++ show name ++ " " ++ show args+                   reduced <- fn args+                   updateValue ptr reduced+                   return reduced+          worker val = return val+runEvalPrimitive val = error $ "unhandled eval: " ++ show val++fromPointer :: Ptr a -> EvalValue+fromPointer ptr = Lit (Lint $ fromIntegral (minusPtr ptr nullPtr))++fromInt :: Int -> EvalValue+fromInt = Lit . Lint . fromIntegral++binOp :: (EvalValue -> EvalValue -> Bool) -> Gen (AnyArg -> AnyArg -> CompValue)+binOp fn+    = do return $ \(AnyArg a) (AnyArg b) ->+                     noScope $ if a `fn` b then return (Lit (Lint 1)) else return (Lit (Lint 0))+++binIntOp :: (Int -> Int -> Int) -> Gen (IntArg -> IntArg -> CompValue)+binIntOp fn+    = return $ \(IntArg a) (IntArg b) -> noScope $ return (Lit (Lint $ fromIntegral (fn a b)))++realWorld :: EvalValue+realWorld = Empty++++++-- Mechanism for the primitives++class IsPrimitive a where toPrimHandle :: String -> a -> [EvalValue] -> CompValue++instance (IsPrimitive b, FromArg a) => IsPrimitive (a -> b) where+    toPrimHandle name fn (x:xs) = do val <- liftIO $ fromArg x+                                     toPrimHandle name (fn val) xs+    toPrimHandle name fn [] = error $ "Grin.Eval.Primitives.toPrimHandle: Not enough arguments for: " ++ name++instance IsPrimitive (CompValue) where+    toPrimHandle name fn [] = fn+    toPrimHandle name fn _  = error $ "Grin.Eval.Primitives.toPrimHandle: Too many arguments to: " ++ name++class FromArg a where fromArg :: EvalValue -> IO a++instance FromArg AnyArg where+    fromArg = return . AnyArg+instance FromArg RealWorld where+    fromArg Empty = return RealWorld+    fromArg v     = error $ "Grin.Eval.Primitives.fromArg: Expected realWorld: " ++ show v+instance FromArg IntArg where+    fromArg (Lit (Lint i))  = return (IntArg $ fromIntegral i)+    fromArg (Lit (Lchar c)) = return (IntArg $ ord c)+    fromArg v               = error $ "Grin.Eval.Primitives.fromArg: Expected integer: " ++ show v+instance FromArg CharArg where+    fromArg (Lit (Lchar c)) = return (CharArg c)+    fromArg (Lit (Lint i))  = return (CharArg (chr $ fromIntegral i))+    fromArg v               = error $ "Grin.Eval.Primitives.fromArg: Expected char: " ++ show v+instance FromArg ArrayArg where+    fromArg (Array arr) = return (ArrayArg arr)+    fromArg v           = error $ "Grin.Eval.Primitives.fromArg: Expected array: " ++ show v+instance FromArg HeapArg where+    fromArg (HeapPointer ptr) = return (HeapArg ptr)+    fromArg v                 = error $ "Grin.Eval.Primitives.fromArg: Expected heap pointer: " ++ show v+instance FromArg PtrArg where+    fromArg (Lit (Lstring str)) = do ptr <- liftIO $ newCString str+                                     return $ PtrArg (castPtr ptr)+    fromArg (Lit (Lint ptr))    = return $ PtrArg (nullPtr `plusPtr` fromIntegral ptr)+    fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected pointer: " ++ show v+++mkPrimitive :: IsPrimitive a => String -> Gen a -> (String, GlobalScope -> Primitive)+mkPrimitive name fn+    = (name, \global -> Primitive { primName = name+                                  , primHandle = toPrimHandle name (fn global) })++++
+ src/Grin/Eval/Types.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeSynonymInstances, GeneralizedNewtypeDeriving #-}+module Grin.Eval.Types where++import Grin.Types hiding (Value(..))+import qualified Grin.Types as Grin++import qualified Data.Map as Map+import Control.Monad.Reader++import CompactString+import Grin.Types hiding (Value(..))++import qualified Data.Map as Map+import Control.Monad.State+import Data.Char; import Data.Int++++type HeapPointer = Int+type Heap = Map.Map HeapPointer EvalValue+data EvalValue+    = CNode Renamed Int [EvalValue]+    | FNode Renamed CompFunction Int [EvalValue]+    | Lit Lit+    | HeapPointer HeapPointer+    | Hole Int+    | Array [EvalValue]+    | Vector [EvalValue]+    | Empty+      deriving (Show,Eq,Ord)++type LocalScope = Map.Map Renamed EvalValue+data GlobalScope = GlobalScope { globalCAFs  :: Map.Map Renamed HeapPointer+                               , globalFuncs :: Map.Map Renamed CompFunction }++type CompFunction = [EvalValue] -> CompExpression+instance Eq CompFunction where _ == _ = False+instance Ord CompFunction where _ `compare` _ = LT+instance Show CompFunction where show _ = "function"+data EvalState+    = EvalState { stateHeap      :: Heap+                , stateFree      :: HeapPointer+                , stateArgs      :: [String] } deriving Show+newtype Comp a = CompExpression { unComp :: StateT EvalState (ReaderT LocalScope IO) a }+    deriving (MonadState EvalState, MonadReader LocalScope, MonadIO, Monad)++type CompExpression = Comp EvalValue+type CompValue = Comp EvalValue+type Gen a = GlobalScope -> a+
− src/Grin/EvalInline.hs 
@@ -1,167 +0,0 @@-module Grin.EvalInline(createEvalApply) where---import Control.Monad.Identity-import List-import qualified Data.Set as Set-import qualified Data.Map as Map---import StringTable.Atom-import Grin.Grin-import Grin.Noodle-import GenUtil-import Support.FreeVars(freeVars)-import Support.CanType(getType)-import Util.Once-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 = Return $ [NodeC (partialTag fn (n - 1)) (vs ++ a2s)]-          | otherwise = error "createApply"-         where-            Just (_,ty) = findArgsType te fn--{-# 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 (App fn [fun] ty) | fn == funcApply = do-            fn' <- runOnceMap appMap (TyUnit,ty) $ do-                u <- newUniq-                return (toAtom $ "bapply_" ++ show u)-            return (App fn' [fun] ty)-        g (App fn [fun,arg] ty) | fn == funcApply = 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 = Map.fromList ntyenv-    return $ setGrinFunctions (apps ++ funcs) grin { grinTypeEnv = TyEnv (tyEnv `Map.union` appTyEnv) }-----
+ src/Grin/FromCore.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE PatternGuards #-}+module Grin.FromCore+    ( coreToGrin+    ) where++import CompactString+import Grin.Types      as Grin+import Grin.SimpleCore as Simple++import qualified Grin.Lowering.GHCism as GHCism++import Data.List+import Control.Monad.State+import Control.Monad.Reader++import qualified Data.Map as Map+++data Env+    = Env { scope :: Map.Map Variable Renamed+          , arities :: Map.Map Variable Int+          }+emptyEnv = Env Map.empty Map.empty++type M a = ReaderT Env (State Int) a++coreToGrin :: [SimpleType] -> [SimpleDef] -> Grin+coreToGrin tdefs defs+    = let gen = tdefsToNodes tdefs $ \nodes ->+                let (defs',cafs) = splitCAFs defs in+                bindCAFs cafs $+                defsToFuncs defs' $ \funcs ->+                defsToCAFs cafs $ \cafs' ->+                get >>= \u ->+                asks scope >>= \varScope -> +                return (GHCism.lower varScope Grin { grinNodes     = nodes+                                                   , grinCAFs      = cafs'+                                                   , grinFunctions = funcs+                                                   , grinUnique    = u+                                                   })+      in evalState (runReaderT gen emptyEnv) 0++tdefsToNodes :: [SimpleType] -> ([NodeDef] -> M a) -> M a+tdefsToNodes tdefs fn+    = bindVariables (map simpleTypeName tdefs) $ \_ ->+      markArities [ (simpleTypeName t, simpleTypeArity t) | t <- tdefs ] $+      fn =<< mapM tdefToNode tdefs++tdefToNode :: SimpleType -> M NodeDef+tdefToNode stype+    = do name <- lookupVariable (simpleTypeName stype)+         return (NodeDef name ConstructorNode (replicate (simpleTypeArity stype) PtrType))+++splitCAFs :: [SimpleDef] -> ([SimpleDef], [(Variable,Variable)])+splitCAFs []     = ([],[])+splitCAFs (x:xs)+    = let (defs,cafs) = splitCAFs xs+      in if simpleDefArity x == 0+            then let cafName = mkCAFName (simpleDefName x)+                 in ( x{simpleDefName = cafName}:defs+                    , (simpleDefName x, cafName):cafs)+            else (x:defs,cafs)++mkCAFName name = name `CompactString.append` fromString "_caf"++defsToCAFs :: [(Variable,Variable)] -> ([CAF] -> M a) -> M a+defsToCAFs vs fn+    = do cafs <- mapM defToCAF vs+         fn cafs++defToCAF :: (Variable,Variable) -> M CAF+defToCAF (varName, fnName)+    = do var <- lookupVariable varName+         fn <- lookupVariable fnName+         return $ CAF { cafName = var+                      , cafValue = Node fn FunctionNode 0 [] }++bindCAFs :: [(Variable,Variable)] -> M a -> M a+bindCAFs vs fn = bindVariables (map fst vs) $ \_ -> fn++defsToFuncs :: [SimpleDef] -> ([FuncDef] -> M a) -> M a+defsToFuncs sdefs fn+    = bindSimpleDefs sdefs $+      do funcs <- mapM defToFunc sdefs+         fn funcs++defToFunc :: SimpleDef -> M FuncDef+defToFunc sdef+    = bindVariables (simpleDefArgs sdef) $ \renamed ->+      do exp <- translate Strict (simpleDefBody sdef)+         name <- lookupVariable (simpleDefName sdef)+         return FuncDef { funcDefName = name+                        , funcDefArgs = renamed+                        , funcDefBody = exp }++data Context = Strict | Lazy++translate :: Context -> SimpleExp -> M Expression+translate cxt simplExp+    = case simplExp of+       Simple.CaseStrict exp binding alts ->+         bindVariable binding $ \renamed ->+           do e <- translate Strict exp+              alts' <- mapM (alternative (translate cxt)) alts+              return $ e :>>= renamed :-> Grin.Case renamed alts'+       Simple.Case exp binding alts | simpleExpIsPrimitive exp ->+         bindVariable binding $ \renamed ->+           do e <- translate cxt exp+              alts' <- mapM (alternative (translate cxt)) alts+              return $ e :>>= renamed :-> Grin.Case renamed alts'+       Simple.Case exp binding alts ->+         bindVariable binding $ \renamed ->+           do e <- translate Strict exp+              v <- newVariable+              alts' <- mapM (alternative (translate cxt)) alts+              return $ e :>>= v :-> Store (Variable v) :>>= renamed :-> Grin.Case v alts'+       Simple.Primitive p ->+         return $ Application (Builtin p) []+       Var var isUnboxed ->+         do name <- lookupVariable var+            mbArity <- findArity var+            case mbArity of+              Nothing -> case cxt of+                           Strict | not isUnboxed -> return $ eval name+                           _                      -> return $ Unit (Variable name)+              Just n  -> case cxt of+                           Strict -> return $ Unit (Node name FunctionNode n [])+                           Lazy   -> return $ Store (Node name FunctionNode n [])+       Dcon con ->+         do name <- lookupVariable con+            Just n <-findArity con+            case cxt of+              Strict -> return $ Unit (Node name ConstructorNode n [])+              Lazy   -> return $ Store (Node name ConstructorNode n [])+       Simple.Lit lit ->+         return $ Unit (Grin.Lit lit)+       Let bind func args arity e ->+         bindVariable bind $ \bind' ->+         do func' <- lookupVariable func+            args' <- mapM lookupVariable args+            e' <- translate cxt e+            return $ Store (Node func' FunctionNode (arity-length args) args') :>>= bind' :-> e'+       LetStrict bind fn e ->+         bindVariable bind $ \bind' ->+         do fn' <- translate Strict fn+            e' <- translate cxt e+            return $ fn' :>>= bind' :-> e'+       App fn args ->+         let process acc [] = call (reverse acc)+             process acc (x:xs)+                 = do e <- translate Lazy x+                      v <- newVariable+                      r <- process (v:acc) xs+                      return $ e :>>= v :-> r+             call vs = case fn of+                         Simple.Primitive p  -> return $ Application (Builtin p) vs+                         Simple.External e _ _ -> return $ Application (Grin.External e) vs+                         Var var isUnboxed -> do name <- lookupVariable var+                                                 mbArity <- findArity var+                                                 case mbArity of+                                                   Nothing -> case cxt of Lazy -> mkApplyLazy vs name; Strict -> mkApplyStrict vs name+                                                   Just n  -> do let (now,later) = splitAt n vs+                                                                 let node = Node name FunctionNode (n-length now) now+                                                                 case cxt of+                                                                   Lazy -> do v <- newVariable+                                                                              ap <- mkApplyLazy later v+                                                                              return $ Store node :>>= v :-> ap+                                                                   Strict -> case n `compare` length vs of+                                                                               GT -> return $ Unit node+                                                                               EQ -> return $ Application name now+                                                                               LT -> do v <- newVariable+                                                                                        ap <- mkApplyStrict later v+                                                                                        return $ Store node :>>= v :-> ap+                         Dcon con | Just n <- dconIsVector con+                                  -> return $ Unit $ Vector vs+                         Dcon con -> do name <- lookupVariable con+                                        Just n <- findArity con+                                        case cxt of+                                          Strict -> return $ Unit (Node name ConstructorNode (n-length vs) vs)+                                          Lazy   -> return $ Store (Node name ConstructorNode (n-length vs) vs)+                         e -> do e' <- translate Lazy e+                                 v  <- newVariable+                                 app <- case cxt of Lazy -> mkApplyLazy vs v; Strict -> mkApplyStrict vs v+                                 return (e' :>>= v :-> app)+             mkApplyLazy [] v+                 = return $ Unit (Variable v)+             mkApplyLazy (x:xs) v+                 = do v' <- newVariable+                      r <- mkApplyLazy xs v'+                      return $ applyCell v x :>>= v' :-> r+             mkApplyStrict xs v+                 = do let loop v [] = return $ Unit (Variable v)+                          loop v (x:xs) = do v' <- newVariable+                                             r  <- loop v' xs+                                             return $ apply v x :>>= v' :-> r+                      v' <- newVariable+                      r <- loop v' xs+                      return $ eval v :>>= v' :-> r+         in process [] args+       LetRec defs e ->+         let binds = [ bind | (bind,_,_,_) <- defs ]+             funcs = [ func | (_,func,_,_) <- defs ]+             args  = [ args | (_,_,args,_) <- defs ]+             arities = [ arity | (_,_,_,arity) <- defs ] in+         bindVariables binds $ \binds' ->+         do funcs' <- mapM lookupVariable funcs+            args'  <- mapM (mapM lookupVariable) args+            e' <- translate cxt e+            vars <- replicateM (length defs) newVariable+            let holes = foldr (\(bind,arity) b -> Store (Hole arity) :>>= bind :-> b ) updates (zip binds' arities)+                updates = foldr (\(bind,fn,args,arity,var) b ->+                                 update bind fn args arity var :>>+                                 b ) e' (zip5 binds' funcs' args' arities vars)+            return holes+       Note _ e ->+          translate cxt e+--       Label str -> error $ "label: " ++ str+       Simple.External fn conv _ -> return $ Unit $ Variable $ Grin.External fn+--       DynExternal fn   -> error $ "dynexternal: " ++ fn+       _ ->+          return $ Unit Empty++dconIsVector con+    = Map.lookup con (Map.fromList vectors)+    where vectors = [ (fromString "ghc-prim:GHC.Prim.(# #)", 1)+                    , (fromString "ghc-prim:GHC.Prim.(#,#)", 2)+                    , (fromString "ghc-prim:GHC.Prim.(#,,#)", 3)+                    , (fromString "ghc-prim:GHC.Prim.(#,,,#)", 4)+                    , (fromString "ghc-prim:GHC.Prim.(#,,,,#)", 5)+                    , (fromString "ghc-prim:GHC.Prim.(#,,,,,#)", 6)+                    , (fromString "ghc-prim:GHC.Prim.(#,,,,,,#)", 7)+                    , (fromString "ghc-prim:GHC.Prim.(#,,,,,,,#)", 8)+                    ]+++{-++-- const application+fn f = f 10+fn f = eval f >>= \v -> apply v (Lit 10)++-- partial function application+fn f = f putStrLn+fn f = eval f >>= \v -> apply v (FputStrLn)++-- CAF application+fn f = f fibs+fn f = eval f >>= \v -> apply v fibs++-}++update bind fn args arity var+    = Unit (Node fn FunctionNode (arity-length args) args) :>>= var :->+      Application (Builtin $ fromString "update") [bind, var]+eval v = Application (Builtin $ fromString "eval") [v]+apply a b = Application (Builtin $ fromString "apply") [a,b]+applyCell a b = Store (Node (Builtin $ fromString "evalApply") FunctionNode 0 [a,b])++-- Translate a Core alternative to a Grin alternative+alternative :: (SimpleExp -> M Expression) -> Simple.Alt -> M Grin.Alt+alternative fn (Acon con bs e) | Just n <- dconIsVector con+    = bindVariables bs $ \renamed ->+      do e' <- fn e+         return $ Vector renamed :> e'+alternative fn (Acon con bs e)+    = bindVariables bs $ \renamed ->+      do e' <- fn e+         name <- lookupVariable con+         return $ Node name ConstructorNode 0 renamed :> e'+alternative fn (Adefault e)+    = do e' <- fn e+         v <- newVariable+         return $ Variable v :> e'+alternative fn (Alit lit e)+    = do e' <- fn e+         return $ Grin.Lit lit :> e'++simpleExpIsPrimitive :: SimpleExp -> Bool+simpleExpIsPrimitive (App Simple.Primitive{} _)+    = True+simpleExpIsPrimitive (App Simple.External{} _)+    = True+simpleExpIsPrimitive Simple.Lit{} = True+simpleExpIsPrimitive _+    = False++{-+let a = 1:b+    b = 0:a+in [a,b]++let_a b = Cons 1 b+let_b a = Cons 0 a++store Hole >>= \a ->+store Hole >>= \b ->+update a (Let_a b) >>+update b (Let_b a)+++let a = 1:a+in++let_a a = Cons 1 a+a := Hole+a := Let_a a+++-}++++bindVariable :: Variable -> (Renamed -> M a) -> M a+bindVariable var fn+    = do u <- newUnique+         let renamed = Aliased u var+         local (\env -> env{scope = Map.insertWith errMsg var renamed (scope env)}) (fn renamed)+    where errMsg = error $ "Grin.FromCore.bindVariable: duplicate variable: " ++ show var++bindVariables :: [Variable] -> ([Renamed] -> M a) -> M a+bindVariables vs fn+    = worker [] vs+    where worker acc [] = fn (reverse acc)+          worker acc (x:xs) = bindVariable x (\r -> worker (r:acc) xs)++lookupVariable :: Variable -> M Renamed+lookupVariable var+    = asks $ \env -> Map.findWithDefault err var (scope env)+    where err = error $ "Variable not found: " ++ show var++bindSimpleDef :: SimpleDef -> M a -> M a+bindSimpleDef sdef fn+    = bindVariable (simpleDefName sdef) $ \_ ->+      markArity (simpleDefName sdef) (simpleDefArity sdef) fn++bindSimpleDefs :: [SimpleDef] -> M a -> M a+bindSimpleDefs [] = id+bindSimpleDefs (x:xs) = bindSimpleDef x . bindSimpleDefs xs++markArity :: Variable -> Int -> M a -> M a+markArity var arity+    = local $ \env -> env { arities = Map.insert var arity (arities env)}++markArities :: [(Variable, Int)] -> M a -> M a+markArities [] = id+markArities ((v,a):xs) = markArity v a . markArities xs++findArity :: Variable -> M (Maybe Int)+findArity var+    = asks $ \env -> Map.lookup var (arities env)++newVariable :: M Renamed+newVariable = do u <- newUnique+                 return (Anonymous u)++newUnique :: M Int+newUnique = do u <- get+               put (u+1)+               return u++
− src/Grin/FromE.hs 
@@ -1,807 +0,0 @@-module Grin.FromE(compile,disambiguateProgram) where--import Char-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Trans-import Data.Graph(stronglyConnComp, SCC(..))-import Data.IORef-import Data.Monoid-import List-import Maybe-import qualified Data.Set as Set-import qualified Data.Map as Map--import StringTable.Atom---import C.Arch-import C.FFI hiding(Primitive)-import C.Prims-import Control.Monad.Identity-import DataConstructors-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import E.E-import E.FreeVars-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 Support.CanType-import Support.FreeVars---import Support.Tuple-import Util.Graph as G-import Util.Once-import Util.SetLike-import Util.UniqueMonad()-import qualified C.FFI as FFI-import qualified Cmm.Op as Op-import Cmm.Op(ToCmmTy(..))-import qualified FlagDump as FD-import qualified Info.Info as Info-import qualified Stats--import E.Traverse-import qualified Data.Traversable as T---{- | 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_World__,TyUnit),-    (tc_Ref__,TyPtr tyINode),-    (tc_Array__,TyPtr tyINode),-    (tc_MutArray__,TyPtr tyINode)-    ]--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}) <- Map.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))-----stringNameToTy :: String -> Ty---stringNameToTy n = TyPrim (archOpTy archInfo n)--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 }----- Remove all disambiguity due to name shadowing.-disambiguateProgram :: Program -> Program-disambiguateProgram prog-  = evalState (programMapBodies (fn Map.empty) prog) 1-    where fn subst (ELam tvr e)-             = do (old,new) <- rename tvr-                  let newSubst = Map.insert old new subst-                  liftM (ELam new) (fn newSubst e)-          fn subst (EPi tvr e)-              = do (old,new) <- rename tvr-                   let newSubst = Map.insert old new subst-                   liftM (EPi new) (fn newSubst e)-          fn subst (ELetRec defs body)-              = do nameSubst <- forM defs $ \(tvr,_) -> rename tvr-                   let newSubst = Map.fromList nameSubst `Map.union` subst-                   defs' <- forM defs $ \(tvr, e) -> fn newSubst e-                   body' <- fn newSubst body-                   return $ ELetRec (zip (map snd nameSubst) defs') body'-          fn subst ec@(ECase e t bind alts def fv)-              = do e' <- fn subst e-                   (old,new) <- rename bind-                   let subst' = Map.insert old new subst-                   def' <- T.mapM (fn subst') def-                   let alt (Alt lc@(LitCons{litArgs=args}) e)-                          = do args' <- mapM rename args-                               let newSubst = Map.fromList args' `Map.union` subst'-                               e' <-fn newSubst e-                               return $ Alt lc{litArgs = map snd args'} e'-                       alt (Alt lit e) = do e' <- fn subst' e-                                            return $ Alt lit e'-                   alts' <-mapM alt alts-                   return $ caseUpdate $ ECase e' t new alts' def' fv-          fn subst (EVar tvr)-              = case Map.lookup tvr subst of-                  Nothing  -> return $ EVar tvr-                  Just new -> return $ EVar new-          fn subst (ELit (LitCons name args ty alias))-              = do args' <- mapM (fn subst) args-                   return $ ELit (LitCons name args' ty alias)-          fn subst e = emapE (fn subst) e-          genNewId :: State Int Id-          genNewId = do s <- get-                        put (s+1)-                        return (anonymous s)-          rename tvr | idIsNamed (tvrIdent tvr) = return (tvr,tvr)-                     | otherwise = do new <- genNewId-                                      return (tvr, tvr{tvrIdent = new})------{-# 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 = toAtom "b_main"-    wdump FD.Progress $ do-        putErrLn $ "Found" <+> tshow (length cc) <+> "CAFs to convert to constants," <+> tshow (length reqcc) <+> "of which are recursive."-        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 (TyPtr TyNode)) | (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) [] []))-        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 $ Map.fromList (Map.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_ [ Update (Var v (TyPtr TyNode)) node | (v,node) <- cafs ]-        ds' = ds ++ fbaps-        a @>> b = a :>>= ([] :-> b)-        sequenceG_ [] = Return []-        sequenceG_ (x:xs) = foldl (@>>) x xs-    let grin = setGrinFunctions theFuncs emptyGrin {-            grinEntryPoints = Map.insert funcMain (FfiExport "_amain" Safe CCall, ([],"void")) $-                                Map.fromList epv,-            grinPhase = PhaseInit,-            grinTypeEnv = newTyEnv,-            grinCafs = [ (x,NodeC tagHole []) | (x,_) <- cafs]-            }-        theFuncs = (funcMain ,[] :-> initCafs :>>= [] :->  discardResult (App (scTag mainEntry) [] [])) : efv ++ ds'-    return grin-    where-    scMap = fromList [ (tvrIdent t,toEntry x) |  x@(t,_,_) <- map combTriple $ progCombinators prog]-    initTyEnv = mappend primTyEnv $ TyEnv $ Map.fromList $ concat [ makePartials (a,b,c) | (_,(a,b,c)) <-  massocs scMap] ++-                                                           concat [con x| x <- Map.elems $ constructorMap dataTable, conType x /= eHash]-    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 (TyPtr TyNode) 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 . Map.map toTyTy $ Map.fromList $ [-    (tagArrow,([tyDNode, tyDNode],[TyNode])),-    (funcEval, ([tyINode],[tyDNode])),-    (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 = i, tvrType =  a}) b) | isEmptyId i  =  Const $ NodeC tagArrow [conv a,conv b]-    conv (EVar v) | v `Set.member` lbs = Var (cafNum v) (TyPtr TyNode)-    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"-    | conAlias cons /= NotAlias = 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)--instance ToVal TVr where-    toVal TVr { tvrType = ty, tvrIdent = num } = case toType (TyPtr TyNode) ty of---        TyTup [] -> Tup []-        ty -> Var (V (idToInt num)) ty---doApply x y ty | not (keepIt y) = App funcApply [x] ty-doApply x y ty = App funcApply [x,y] ty--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 (Fetch (toVal tvr))-        Nothing -> return $ App funcEval [toVal tvr] fty--compile' ::  CEnv -> (TVr,[TVr],E) -> C (Atom,Lam)-compile' cenv (tvr,as,e) = ans where-    ans = do-        --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 $ Return [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-    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 <- con e = return (Return z)---    ce (EPrim ap@(APrim (PrimPrim prim) _) as _) = f (fromAtom prim) as where---        -- artificial dependencies-        f "newWorld__" [_] = do-            return $ Return []-        f "dependingOn" [e,_] = ce e---        -- references-        f "newRef__" [v,_] = do-            let [v'] = args [v]-            return $ Alloc { expValue = v', expCount = toUnVal (1::Int), expRegion = region_heap, expInfo = mempty }-        f "readRef__" [r,_] = do-            let [r'] = args [r]-            return $ Fetch (Index r' (toUnVal (0::Int)))-        f "writeRef__" [r,v,_] = do-            let [r',v'] = args [r,v]-            return $ Update (Index r' (toUnVal (0::Int))) v'--        -- arrays-        f "newMutArray__" [v,def,_] = do-            let [v',def'] = args [v,def]-            return $ Alloc { expValue = def', expCount = v', expRegion = region_heap, expInfo = mempty }-        f "newBlankMutArray__" [v,_] = do-            let [v'] = args [v]-            return $ Alloc { expValue = ValUnknown (TyPtr TyNode), expCount = v', expRegion = region_heap, expInfo = mempty }-        f "readArray__" [r,o,_] = do-            let [r',o'] = args [r,o]-            return $ Fetch (Index r' o')-        f "indexArray__" [r,o] = do-            let [r',o'] = args [r,o]-            return $ Fetch (Index r' o')-        f "writeArray__" [r,o,v,_] = do-            let [r',o',v'] = args [r,o,v]-            return $ Update (Index r' o') v'--        f ft [v,_]  | ft `elem` ["unsafeFreezeArray__", "unsafeThawArray__"] = do-            let [v'] = args [v]-            return $ Return [v']-        f p xs = fail $ "Grin.FromE - Unknown primitive: " ++ show (p,xs)---    -- other primitives-    ce (EPrim ap@(APrim p _) xs ty) = do-        let prim = ap-            xs' = keepIts $ args xs-            ty' = toTypes TyNode ty--        case p of-            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 isEmptyId (tvrIdent b) 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 = i },EVar etvr) | isEmptyId i -> 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 = i },_) | isEmptyId i -> 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] :-> Store v :>>= [toVal b] :-> Case v (as ++ def)-            (_,_) | otherwise -> do-                    as <- mapM cp as-                    def <- createDef d newNodeVar-                    return $ e :>>= [toVal b] :-> Case v (as ++ def)-    ce e = error $ "ce: " ++ render (pprint (funcName,e))--    localEvaled vs v action = local (\lenv -> lenv { evaledMap = nm `mappend` evaledMap lenv }) action where-        nm = fromList [ (tvrIdent x, v) | x <- vs, not (isEmptyId (tvrIdent x)) ]--    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)--    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] :-> App funcApply [v] ty)-    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] :-> App funcApply [v] [TyNode]) 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 <- (TyPtr TyNode:map getType as)]-            s = Store (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 $ Map.insert sfn sft (Map.insert 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 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 $ 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 = Store (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 Store (NodeC pt as)-                | otherwise -> do -- length as == length as'-                    return $ Store (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-        -- All recursive lets should have been lifted to the top-level.-        f (Right bs:ds) x | any (isELam . snd) bs = error "Unlifted let in Grin.FromE.compile'"-        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 -> Store (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)) = (Update 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 :: E -> Maybe 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 = i, tvrType = a}) b) | isEmptyId i, 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 = i, tvrType = x}) y) | isEmptyId i= do-        return $  [NodeC tagArrow (args [x,y])]-    con v@(ELit LitCons { litName = n, litArgs = es })-        | conAlias cons /= NotAlias = 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 (TyPtr TyNode)) newVar-    newVar = do-        i <- liftIO $ readIORef (counter cenv)-        liftIO $ (writeIORef (counter cenv) $! (i + 2))-        return $! V i----- | converts an unboxed literal-literal :: E -> Maybe [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 aprim@(APrim p _) xs ty) | Just ptype <- toCmmTy ty, primIsConstant p = do-    xs <- mapM literal xs-    return $ [ValPrim aprim (concat xs) (TyPrim ptype)]-literal _ = fail "not a literal term"-
− src/Grin/Grin.hs 
@@ -1,598 +0,0 @@-{-# OPTIONS_GHC -funbox-strict-fields #-}--module Grin.Grin(-    Callable(..),-    Exp(..),-    FuncDef(..),-    FuncProps(..),-    Grin(..),-    TyThunk(..),-    Lam(..),-    Phase(..),-    Tag,-    updateFuncDefProps,-    Ty(..),-    TyEnv(..),-    TyTy(..),-    tyTy,-    Val(..),-    Var(..),-    extendTyEnv,-    createFuncDef,-    setGrinFunctions,-    grinFuncs,-    emptyGrin,-    tyINode,-    tyDNode,-    findArgs,-    findArgsType,-    findTyTy,-    funcApply,-    funcEval,-    gEval,-    grinEntryPointNames,-    isHole,-    isValUnknown,-    isVar,-    n0,n1,n2,n3,-    p0,p1,p2,p3,-    partialTag,-    phaseEvalInlined,-    properHole,-    tagFlipFunction,-    tagHole,-    tagIsFunction,-    tagIsPartialAp,-    tagIsSuspFunction,-    tagIsTag,-    tagIsWHNF,-    tagToFunction,-    tagUnfunction,-    v0,v1,v2,v3,lamExp,lamBind,-    valIsNF-    ) where--import Char-import Control.Monad.Identity-import Data.Monoid-import List(isPrefixOf)-import Prelude-import qualified Data.Map as Map-import qualified Data.Set as Set--import StringTable.Atom-import C.FFI-import C.Prims-import Doc.DocLike-import GenUtil-import Name.VConsts-import Cmm.Number-import Options-import Support.CanType-import Support.FreeVars-import Util.Perhaps-import qualified Info.Info as Info-import qualified Cmm.Op as Op-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) ( do we need--- this for polymorphic recursion? )--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 (Map.Map Atom TyTy)-    deriving(Monoid)---tagHole = toAtom "@hole"-funcApply = toAtom "@apply"-funcEval = toAtom "@eval"--gEval :: Val -> Exp-gEval x = App funcEval [x] [TyNode]---- lazy node sptr_t-tyINode = TyPtr TyNode--- strict node wptr_t-tyDNode = TyNode---instance TypeNames Ty where-    tIntzh = TyPrim (Op.bits32) -- Ty (toAtom "int")-    tEnumzh = TyPrim (Op.bits16) -- Ty (toAtom "int")-    tCharzh = TyPrim (Op.bits32) -- Ty (toAtom "HsChar")-    --tStar = Ty (toAtom "*")--data Callable = Continuation | Function | Closure | LocalFunction | Primitive'-    deriving(Eq,Ord,Show)---type Tag = Atom--newtype Var = V Int-    deriving(Eq,Ord,Enum)--instance Show Var where-    showsPrec _ (V n) xs = 'v':shows n xs----infixr 1  :->, :>>=---data Lam = [Val] :-> Exp-    deriving(Eq,Ord,Show)--data Exp =-     Exp :>>= Lam                                                         -- ^ Sequencing - the same as >>= for monads.-    | App       { expFunction  :: Atom,-                  expArgs :: [Val],-                  expType :: [Ty] }                                       -- ^ Application of functions and builtins-    | Prim      { expPrimitive :: APrim,-                  expArgs :: [Val],-                  expType :: [Ty] }                                       -- ^ Primitive operation-    | Case      { expValue :: Val, expAlts :: [Lam] }                     -- ^ Case statement-    | Return    { expValues :: [Val] }                                    -- ^ Return a value-    | Store     { expValue :: Val }                                       -- ^ Allocate a new heap node-    | Fetch     { expAddress :: Val }                                     -- ^ Load given heap node-    | Update    { expAddress :: Val, expValue :: Val }                    -- ^ Update given heap node-    | 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-    deriving(Eq,Show,Ord)--data Val =-    NodeC !Tag [Val]          -- ^ Complete node with constant tag-    | Const Val               -- ^ pointer to constant data, only Lit, Tag, and NodeC may be children-    | Lit !Number Ty          -- ^ Literal-    | Var !Var Ty             -- ^ Variable-    | Unit                    -- ^ Empty value used as placeholder-    | ValPrim APrim [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 value-    deriving(Eq,Ord)--data Ty =-    TyPtr Ty                 -- ^ pointer to a heap location which contains its argument-    | TyNode                   -- ^ a whole tagged node-    | TyPrim Op.Ty             -- ^ a basic type-    | TyUnit                   -- ^ type of Unit-    | TyCall Callable [Ty] [Ty]  -- ^ something call,jump, or cut-to-able-    | TyRegion                 -- ^ a region-    | TyUnknown                -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation-    deriving(Eq,Ord)----data FuncDef = FuncDef {-    funcDefName  :: Atom,-    funcDefBody  :: Lam,-    funcDefCall  :: Val,-    funcDefProps :: FuncProps-    } deriving(Eq,Ord,Show)--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 defeninitions" ++ show (fsts xs)-setGrinFunctions xs grin = grin { grinFunctions = map (uncurry (createFuncDef False)) xs }---extendTyEnv ds (TyEnv env) = TyEnv (Map.fromList xs `mappend` env) where-    xs = [ (funcDefName d,tyTy { tySlots = ss, tyReturn = r }) |  d <- ds, let (ss,r) = funcType $ funcDefProps d]---- 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-    }---instance Show Ty where-    show TyNode = "N"-    show (TyPtr t) = '&':show t-    show (TyUnit) = "()"-    show (TyPrim t) = show t-    show TyRegion = "R"-    show (TyCall c as rt) = show c <> tupled (map show as) <+> "->" <+> show rt-    show TyUnknown = "?"---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)-        | TyPtr TyNode <- t = text "ni" <> tshow i-        | TyNode <- t = text "nd" <> tshow i-        | TyPtr (TyPtr TyNode) <- t = text "np" <> tshow i-        | 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  = char 'p' <> tshow i-        | TyPrim (Op.TyBits (Op.BitsArch Op.BitsMax)  _) <- t  = char 'm' <> 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)--data Phase = PhaseInit | PostInlineEval | PostAeOptimize | PostDevolve-    deriving(Show,Eq,Ord,Enum)--phaseEvalInlined e = e >= PostInlineEval---data Grin = Grin {-    grinEntryPoints   :: Map.Map Atom (FfiExport, ([ExtType], ExtType)),-    grinPhase         :: !Phase,-    grinTypeEnv       :: TyEnv,-    grinFunctions     :: [FuncDef],-    grinSuspFunctions :: Set.Set Atom,-    grinPartFunctions :: Set.Set Atom,-    grinStats         :: !Stats.Stat,-    grinCafs          :: [(Var,Val)],-    grinUnique        :: Int-                 }---emptyGrin = Grin {-    grinEntryPoints = mempty,-    grinPhase = PhaseInit,-    grinTypeEnv = mempty,-    grinFunctions = [],-    grinSuspFunctions = mempty,-    grinPartFunctions = mempty,-    grinStats = mempty,-    grinCafs = mempty,-    grinUnique = 1-                 }--grinEntryPointNames = Map.keys . grinEntryPoints---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-    TyPtr TyNode -> Const (properHole TyNode)-    ty@(TyPrim _) -> (Lit 0 ty)-    ~TyNode -> (NodeC tagHole [])--isHole x = x `elem` map properHole [TyPtr TyNode, TyNode]--isValUnknown ValUnknown {} = True-isValUnknown _ = False--------------- Look up stuff in the typing environment.------------findTyTy (TyEnv m) a | Just tyty <-  Map.lookup a m = return tyty-findTyTy (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case Map.lookup (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 (TyPtr TyNode)-p1 = Var v1 (TyPtr TyNode)-p2 = Var v2 (TyPtr TyNode)-p3 = Var v3 (TyPtr TyNode)---instance CanType e t => CanType [e] [t] where-    getType es = map getType es--instance CanType Exp [Ty] where-    getType (_ :>>= (_ :-> e2)) = getType e2-    getType (Prim _ _ ty) = ty-    getType App { expType = t } = t-    getType (Store v) = [TyPtr (getType v)]-    getType (Return v) = getType v-    getType (Fetch v) = case getType v of-        TyPtr t -> [t]-        _ -> error "Exp.getType: fetch of non-pointer type"-    getType (Error _ t) = t-    getType (Update w v) = []-    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--instance CanType Val Ty where-    getType (Var _ t) = t-    getType (Lit _ t) = t-    getType (Index v _) = getType v-    getType Unit = TyUnit-    getType (Const t) = TyPtr (getType t)-    getType (NodeC {}) = TyNode-    getType (ValPrim _ _ ty) = ty-    getType (ValUnknown ty) = ty-    getType (Item _ ty) = ty--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 (Fetch v) = freeVars v-    freeVars (Update x y) = freeVars (x,y)-    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)--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 (Fetch v) = freeVars v-    freeVars (Update x y) = freeVars (x,y)-    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)--instance FreeVars Exp [Var] where-    freeVars e = Set.toList $ freeVars e-instance FreeVars Val [Var] where-    freeVars e = Set.toList $ freeVars e-instance FreeVars Lam [Var] where-    freeVars e = Set.toList $ freeVars e--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 (Fetch v) = freeVars v-    freeVars (Update x y) = freeVars (x,y)-    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)---lamExp (_ :-> e) = e-lamBind (b :-> _) = b--isVar Var {} = True-isVar _ = False----
− src/Grin/Grin.hs-boot 
@@ -1,7 +0,0 @@-module Grin.Grin where---data Exp-data Grin-data Val-data Lam
+ src/Grin/HPT.hs view
@@ -0,0 +1,15 @@+module Grin.HPT+    ( analyze+    , lower+    ) where++import Grin.Types               ( Grin )++import Grin.HPT.Environment     ( mkEnvironment )+import Grin.HPT.Solve           ( solve, HeapAnalysis )+import Grin.HPT.Lower           ( lower )+++analyze :: Grin -> (Int, HeapAnalysis)+analyze = solve . mkEnvironment+
+ src/Grin/HPT/Environment.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE OverloadedStrings #-}+module Grin.HPT.Environment+    ( mkEnvironment+    , Equations+    , Rhs(..)+    , RhsValue(..)+    , Lhs(..)+    , singleton+    ) where++import CompactString+import Grin.Types++import qualified Data.Map as Map+import Control.Monad.RWS+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Writer++type HeapPointer = Int+data Lhs = HeapEntry HeapPointer+         | VarEntry Renamed+    deriving (Eq,Ord)++data RhsValue+    = Extract Renamed Renamed Int+    | ExtractVector Renamed Int+    | Eval Renamed+    | Update Renamed Renamed+    | Apply Renamed Renamed+    | PartialApply Renamed Renamed+    | Ident Renamed+    | Fetch Renamed+    | Base+    | Heap HeapPointer+    | Tag Renamed NodeType Int [Rhs]+    | VectorTag [Rhs]+    deriving (Eq,Ord,Show)++-- A set of possible rhs values+newtype Rhs = Rhs [RhsValue] deriving (Eq,Ord,Show)+singleton :: RhsValue -> Rhs+singleton value = Rhs [value]++type Equations = Map.Map Lhs Rhs++++instance Monoid Rhs where+    mempty = Rhs []+    mappend (Rhs a) (Rhs b)+        = Rhs (worker a b)+        where worker [] lst = lst+              worker lst [] = lst+              worker (Tag tag1 nt1 missing1 args1:xs) (Tag tag2 nt2 missing2 args2:ys)+                  = case tag1 `compare` tag2 of+                      LT -> Tag tag1 nt1 missing1 args1 : worker xs (Tag tag2 nt2 missing2 args2:ys)+                      GT -> Tag tag2 nt2 missing2 args2 : worker (Tag tag1 nt1 missing1 args1:xs) ys+                      EQ -> Tag tag1 nt1 (min missing1 missing2) (zipJoin args1 args2):worker xs ys+              worker (y@Tag{}:ys) (x:xs)+                  = x:worker (y:ys) xs+              worker (y:ys) (x@Tag{}:xs)+                  = y:worker ys (x:xs)+              worker (y:ys) (x:xs)+                  = case y `compare` x of+                      LT -> y:worker ys (x:xs)+                      GT -> x:worker (y:ys) xs+                      EQ -> x:worker ys xs++zipJoin :: Monoid a => [a] -> [a] -> [a]+zipJoin [] []         = []+zipJoin [] lst        = zipWith mappend (repeat mempty) lst+zipJoin lst []        = zipWith mappend lst (repeat mempty)+zipJoin (x:xs) (y:ys) = mappend x y : zipJoin xs ys+++type GenReader = Map.Map Renamed [Renamed]+type GenM a = RWS GenReader (Endo Equations) Int a++applications :: Renamed+applications = Builtin "applications"++updates :: Renamed+updates = Builtin "updates"++mkEnvironment :: Grin -> Equations+mkEnvironment grin+    = case execRWS (setupEnvGrin grin) reader 0 of+         (st, eqsEndo) -> appEndo eqsEndo Map.empty+    where reader = Map.fromList [ (funcDefName func, funcDefArgs func) | func <- grinFunctions grin ]++setupEnvGrin :: Grin -> GenM ()+setupEnvGrin grin+    = do forM_ (grinCAFs grin) $ \caf ->+           do hp <- store =<< processVal (cafValue caf)+              addEquation (VarEntry (cafName caf)) (singleton $ Heap hp)+         forM_ (grinFunctions grin) $ \function ->+           do rhs <- setupEnv (funcDefBody function)+              addEquation (VarEntry (funcDefName function)) rhs+              forM_ (zip (funcDefArgs function) [0..]) $ \(arg, n) ->+                addEquation (VarEntry arg)+                            (singleton $ Extract applications (funcDefName function) n)++-- FIXME: Put these in order.+baseBuiltins, vectorBuiltins, unsupportedBuiltins :: [CompactString]+baseBuiltins        = ["<#",">#","<=#",">=#","-#","+#","*#","narrow32Int#"+                      ,"uncheckedIShiftRA#","and#","==#", "remInt#", "noDuplicate#"+                      ,"narrow8Word#", "writeInt8OffAddr#"+                      ,"narrow8Int#", "byteArrayContents#","touch#"+                      ,"uncheckedIShiftL#", "negateInt#"+                      ,"indexCharOffAddr#","minusWord#","geWord#","eqWord#","narrow16Word#"+                      ,"ord#","chr#","or#","narrow32Word#","uncheckedShiftL#","plusWord#"+                      ,"uncheckedShiftRL#","neChar#","gcdInt#","narrow16Int#","timesWord#"+                      ,"writeAddrOffAddr#","writeInt32OffAddr#","quotInt#"+                      ,"leWord#","/=#","writeCharArray#","xor#" ]+vectorBuiltins      = ["unsafeFreezeByteArray#", "newAlignedPinnedByteArray#"+                      , "word2Integer#","integer2Int#", "newPinnedByteArray#"+                      ,"readInt8OffAddr#","readInt32OffAddr#","readAddrOffAddr#","readInt32OffAddr#"]+unsupportedBuiltins = ["raise#","atomicModifyMutVar#","waitWrite#","mkWeak#","writeTVar#"+                      ,"raiseIO#","fork#","atomically#"]+++setupEnv :: Expression -> GenM Rhs+setupEnv (Store val)+    = do hp <- store =<< processVal val+         return $ singleton $ Heap hp+setupEnv (exp :>>= bind :-> rest)+    = do expRhs <- setupEnv exp+         addEquation (VarEntry bind) expRhs+         setupEnv rest+setupEnv (exp :>> rest)+    = do setupEnv exp+         setupEnv rest+setupEnv (Unit val)+    = processVal val+setupEnv (Case val alts)+    = do let valRhs = singleton $ Ident val+         rets <- forM alts $ \(l :> alt) ->+                   case l of+                     Node tag _ _ args -> do forM_ (zip [0..] args) $ \(n,arg) ->+                                               addEquation (VarEntry arg) (singleton $ Extract val tag n)+                                             setupEnv alt+                     Vector args -> do forM_ (zip [0..] args) $ \(n,arg) ->+                                         addEquation (VarEntry arg) (singleton $ ExtractVector val n)+                                       setupEnv alt+                     Lit{}          -> setupEnv alt+                     Variable v     -> do addEquation (VarEntry v) valRhs+                                          setupEnv alt+                     _              -> error $ "setupEnv: Invalid case: " ++ show l+         return $ mconcat rets+setupEnv (Application External{} args)+    = return $ singleton (VectorTag [mempty, singleton Base])++setupEnv (Application (Builtin "eval") [arg])+  = do return $ singleton (Eval arg)+setupEnv (Application (Builtin "apply") [arg1, arg2])+  = do addEquation (VarEntry applications) (singleton $ PartialApply arg1 arg2)+       return $ singleton (Apply arg1 arg2)+setupEnv (Application (Builtin "update") [ptr,val])+    = do addEquation (VarEntry updates) (singleton $ Update ptr val)+         return mempty++setupEnv (Application (Builtin fn) args) | fn `elem` baseBuiltins+    = return $ singleton Base+setupEnv (Application (Builtin fn) args) | fn `elem` vectorBuiltins+    = return $ singleton $ VectorTag [mempty, singleton Base]+setupEnv (Application (Builtin fn) args) | fn `elem` unsupportedBuiltins+    = return mempty++setupEnv (Application (Builtin "makeStablePtr#") [val,realworld])+    = do hp <- store (singleton $ Ident val)+         return $ singleton $ VectorTag [mempty, singleton $ Heap hp]+setupEnv (Application (Builtin "deRefStablePtr#") [ptr,realworld])+    = do return $ singleton $ VectorTag [mempty, singleton $ Fetch ptr]+setupEnv (Application (Builtin "unblockAsyncExceptions#") [fn, realworld])+    = do return $ singleton $ Apply fn realworld+setupEnv (Application (Builtin "blockAsyncExceptions#") [fn, realworld])+    = do return $ singleton $ Apply fn realworld+setupEnv (Application (Builtin "fetch") [a])+    = return $ singleton $ Fetch a+setupEnv (Application (Builtin "newArray#") [size, elt, realworld])+    = do hp <- store (singleton $ Ident elt)+         return $ singleton $ VectorTag [mempty, singleton $ Heap hp]+setupEnv (Application (Builtin "readArray#") [arr, nth, realworld])+    = return $ singleton $ VectorTag [mempty, singleton $ Fetch arr]+setupEnv (Application (Builtin "writeArray#") [arr, nth, elt, realworld])+    = do addEquation (VarEntry updates) (singleton $ Update arr elt)+         return mempty+setupEnv (Application (Builtin builtin) args)+    = error $ "unknown builtin: " ++ show builtin++setupEnv (Application fn args)+    = do funcArgs <- lookupFuncArgs fn+         forM_ (zip funcArgs args) $ \(var, arg) ->+           addEquation (VarEntry var) (singleton $ Ident arg)+         return $ singleton (Ident fn)+++++processVal :: Value -> GenM Rhs+processVal (Node name nt missing args)+    = do case nt of+           FunctionNode ->+             do funcArgs <- lookupFuncArgs name+                forM_ (zip funcArgs args) $ \(funcArg,arg) ->+                  addEquation (VarEntry funcArg) (singleton $ Ident arg)+           ConstructorNode ->+             do return ()+         return $ singleton $ Tag name nt missing (map (singleton . Ident) args)+processVal (Variable var) = return $ singleton $ Ident var+processVal Lit{}          = return $ singleton Base+processVal Hole{}         = return mempty+processVal Empty          = return mempty+processVal (Vector vs)    = return $ singleton $ VectorTag (map (singleton . Ident) vs)++store :: Rhs -> GenM Int+store rhs+  = do u <- get+       put $ u+1+       addEquation (HeapEntry u) rhs+       return u++addEquation :: Lhs -> Rhs -> GenM ()+addEquation lhs rhs+    = tell $ Endo $ Map.insertWith mappend lhs rhs+++lookupFuncArgs :: Renamed -> GenM [Renamed]+lookupFuncArgs func+    = asks $ \funcs ->+      case Map.lookup func funcs of+        Nothing   -> error $ "Couldn't find function: " ++ show func+        Just args -> args++
+ src/Grin/HPT/Lower.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+module Grin.HPT.Lower+    ( lower+    ) where++import Grin.Types++import qualified Data.Map as Map+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Writer+++import Grin.HPT.Environment+import Grin.HPT.Solve++type M a = ReaderT HeapAnalysis (State Int) a++lower :: HeapAnalysis -> Grin -> Grin+lower hpt grin+    = evalState (runReaderT worker hpt) (grinUnique grin)+    where worker = do fns <- mapM lowerFuncDef (grinFunctions grin)+                      unique <- get+                      return grin{ grinFunctions = fns+                                 , grinUnique    = unique }++lowerFuncDef :: FuncDef -> M FuncDef+lowerFuncDef func+    = do body <- lowerExpression (funcDefBody func)+         return $ func{funcDefBody = body}++lowerExpression :: Expression -> M Expression+lowerExpression (a :>>= lam)+    = do a' <- lowerExpression a+         lam' <- lowerLambda lam+         return $ a' :>>= lam'+lowerExpression (a :>> b)+    = do a' <- lowerExpression a+         b' <- lowerExpression b+         return $ a' :>> b'+lowerExpression (Application (Builtin "eval") [a])+    = do f <- newVariable+         HeapAnalysis hpt <- ask+         case Map.lookup (VarEntry a) hpt of+           Just (Rhs rhs) -> do let Rhs rhs' = mconcat [ hpt Map.! HeapEntry hp | Heap hp <- rhs ]+                                alts <- mapM (mkApplyAlt []) rhs'+                                v <- newVariable+                                u <- mkUpdate a f v rhs'+                                return $ Application (Builtin "fetch") [a] :>>= f :->+                                         Case f alts :>>= v :->+                                         u :>> -- Application (Builtin "update") [a,v] :>>+                                         Unit (Variable v)+           Nothing -> return $ Application (Builtin "urk") []+lowerExpression (Application (Builtin "apply") [a,b])+    = do HeapAnalysis hpt <- ask+         case Map.lookup (VarEntry a) hpt of+           Just (Rhs rhs) -> do alts <- mapM (mkApplyAlt [b]) rhs+                                return $ Case a alts+           Nothing -> return $ Application (Builtin "urk") []+lowerExpression (Application fn args)+    = return $ Application fn args+lowerExpression (Case scrut alts)+    = do alts' <- mapM lowerAlt alts+         return $ Case scrut alts'+lowerExpression (Store val)+    = return $ Store val+lowerExpression (Unit val) = return $ Unit val++lowerLambda :: Lambda -> M Lambda+lowerLambda (a :-> b)+    = do b' <- lowerExpression b+         return $ a :-> b'++lowerAlt :: Alt -> M Alt+lowerAlt (a :> b)+    = do b' <- lowerExpression b+         return $ a :> b'++mkUpdate :: Renamed -> Renamed -> Renamed ->[RhsValue] -> M Expression+mkUpdate ptr scrut val tags+    = do fnTags <- sequence [ do args' <- replicateM (length args) newVariable+                                 return $ Node tag FunctionNode n args' | t@(Tag tag FunctionNode n args) <- tags, n == 0 ]+         constrTags <- sequence [ do args' <- replicateM (length args) newVariable+                                     return $ Node tag nt n args' | t@(Tag tag nt n args) <- tags, not (n == 0 && nt == FunctionNode) ]+         let doUpdate = Case val [ tag :> Application (Builtin "update") [ptr,val] | tag <- constrTags ]+         if null fnTags || null constrTags+            then return $ Unit Empty+            else return $ doUpdate++mkApplyAlt :: [Renamed] -> RhsValue -> M Alt+mkApplyAlt extraArgs (Tag tag FunctionNode n argsRhs) | n == length extraArgs+    = do args <- replicateM (length argsRhs) newVariable+         return $ Node tag FunctionNode n args :> Application tag (args ++ extraArgs)+mkApplyAlt extraArgs (Tag tag nt n argsRhs)+    = do args <- replicateM (length argsRhs) newVariable+         return $ Node tag nt n args :> Unit (Node tag nt (n - length extraArgs) (args ++ extraArgs))+mkApplyAlt _ val = error $ "Grin.HPT.Lower.mkApplyAlt: expected tag: " ++ show val++newVariable :: M Renamed+newVariable = do unique <- get+                 put (unique + 1)+                 return $ Anonymous unique+
+ src/Grin/HPT/Solve.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+module Grin.HPT.Solve+    ( HeapAnalysis(..)+    , solve+    ) where++import Grin.Types++import qualified Data.Map as Map+import Control.Monad.Reader+import Control.Monad.Writer++--import System.IO+--import System.IO.Unsafe++import Grin.HPT.Environment++data HeapAnalysis+    = HeapAnalysis (Map.Map Lhs Rhs)+++type M a = ReaderT Equations (Writer (Endo Equations)) a+++solve :: Equations -> (Int, HeapAnalysis)+solve eqs+    = let iterate ls+              = forM_ ls $ \(lhs,rhs) ->+                  do reducedRhs <- reduceEqs rhs+                     addReduced lhs reducedRhs+          loop iter prev+              = case {-traceOut ("\nIteration: " ++ show iter ++ "\n") $-} (execWriter (runReaderT (iterate (Map.toList eqs)) prev)) of+                  newDefs ->+                    let next = (Map.unionWith mappend prev (appEndo newDefs Map.empty))+                    in if prev == next then (iter, HeapAnalysis next) else loop (iter+1) next+      in loop 1 (Map.map (const mempty) eqs)++--traceOut str v = unsafePerformIO (putStr str) `seq` v+++isSubsetOf :: (Monoid a, Eq a) => a -> a -> Bool+a `isSubsetOf` b = b == (a `mappend` b)++addReduced :: Lhs -> Rhs -> M ()+addReduced lhs rhs+    = do orig <- lookupEq lhs+         {-let isNew = not (rhs `isSubsetOf` orig)+               tag = if isNew then "+" else "-"+         traceOut tag $-}+         unless (rhs `isSubsetOf` orig) $ tell $ Endo $ Map.insertWith mappend lhs rhs++reduceEqs :: Rhs -> M Rhs+reduceEqs (Rhs rhs) = do rhs' <- mapM reduceEq rhs+                         return $ mconcat rhs'++reduceEq :: RhsValue -> M Rhs+reduceEq Base      = return $ singleton Base+reduceEq (Heap hp) = return $ singleton $ Heap hp+reduceEq (Ident i) = lookupEq (VarEntry i)+reduceEq (Extract eq tag n)+    = do Rhs eqs' <- lookupEq (VarEntry eq)+         reduceEqs (mconcat [ args `nth` n | Tag t _ _ args <- eqs', t == tag ])+    where nth [] n = mempty --error $ "reduceEq: ExtractVector: " ++ show (eqs, tag, n)+          nth (x:xs) 0 = x+          nth (x:xs) n = nth xs (n-1)+reduceEq (ExtractVector eq n)+    = do Rhs eqs' <- lookupEq (VarEntry eq)+         reduceEqs (mconcat [ args `nth` n | VectorTag args <- eqs' ])+    where nth [] n = error $ "reduceEq: ExtractVector: " ++ show (eq, n)+          nth (x:xs) 0 = x+          nth (x:xs) n = nth xs (n-1)+{-+reduceEq (Tag fn FunctionNode 0 args)+    = do args' <- mapM reduceEqs args+         rets <- lookupEq (VarEntry fn)+         return $ singleton (Tag fn FunctionNode 0 args') `mappend` rets+-}+reduceEq (Tag t nt missing args)+    = do --args' <- mapM reduceEqs args+         return $ singleton (Tag t nt missing args)+reduceEq (VectorTag args)+    = do args' <- mapM reduceEqs args+         return $ singleton (VectorTag args')+reduceEq (Eval i)+    = do Rhs vals <- lookupEq (VarEntry i)+         let f (Heap hp) = do Rhs rhs <- lookupEq (HeapEntry hp)+                              let worker (Tag fn FunctionNode 0 _) = lookupEq (VarEntry fn)+                                  worker other = return $ singleton other+                              rets <- liftM mconcat $ mapM worker rhs+                              addReduced (HeapEntry hp) rets+                              return rets+             f t = error $ "reduceEq: eval: " ++ show (t,i,vals)+         liftM mconcat $ mapM f vals+reduceEq (Fetch i)+    = do Rhs vals <- lookupEq (VarEntry i)+         let f (Heap hp) = lookupEq (HeapEntry hp)+             f Base      = return mempty+             f t = error $ "reduceEq: fetch: " ++ show (t,i,vals)+         liftM mconcat $ mapM f vals+reduceEq (Apply a b)+    = do Rhs vals <- lookupEq (VarEntry a)+         let f (Tag func FunctionNode 1 args)+                 = reduceEq (Ident func)+             f (Tag conc nt n args)+                 | n == 0    = return mempty+                 | otherwise = return $ singleton (Tag conc nt (n-1) (args ++ [singleton (Ident b)]))+             f t             = error $ "reduceEq: apply: " ++ show t+         liftM mconcat $ mapM f vals+reduceEq (PartialApply a b)+    = do Rhs vals <- lookupEq (VarEntry a)+         let f (Tag tag nt n args)+                 | n == 0    = return mempty+                 | otherwise = return $ singleton (Tag tag nt (n-1) (args ++ [singleton (Ident b)]))+             f t             = error $ "reduceEq: apply: " ++ show t+         liftM mconcat $ mapM f vals+reduceEq (Update hp val)+    = do Rhs hps <- lookupEq (VarEntry hp)+         valRhs  <- lookupEq (VarEntry val)+         forM_ hps $ \(Heap hp) -> addReduced (HeapEntry hp) valRhs+         return mempty++lookupEq :: Lhs -> M Rhs+lookupEq lhs+    = asks $ \eqs -> Map.findWithDefault mempty lhs eqs+++
− src/Grin/HashConst.hs 
@@ -1,52 +0,0 @@-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 StringTable.Atom-import Grin.Grin-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/HtmlAnnotate.hs view
@@ -0,0 +1,111 @@+module Grin.HtmlAnnotate where++import Text.PrettyPrint+import qualified Text.XHtml+import Text.XHtml hiding (text,blue,white,align)+import qualified Data.Map as Map++import CompactString+import Grin.Types++annotate :: Map.Map Renamed Html -> Grin -> String+annotate annotations grin+    = h "html" $ h "body" $ h "pre" $ show (ppGrin grin)+    where h t s = "<"++t++">"++s++"</"++t++">"++(<$$>) = ($$)+vsep = vcat+pretty v = text (read (show v))++type QualMap = Map.Map CompactString Bool++grinQualMap :: Grin -> QualMap+grinQualMap grin+    = Map.unionsWith (\_ _ -> True) [nodeMap, funcMap, argsMap]+    where nodeMap = Map.fromListWith (\_ _ -> True) [ (name, False) | NodeDef{nodeName = Aliased _ name} <- grinNodes grin ]+          funcMap = Map.fromListWith (\_ _ -> True) [ (name, False) | FuncDef{funcDefName = Aliased _ name} <- grinFunctions grin ]+          argsMap = Map.fromListWith (\_ _ -> True) [ (name, False) | func <- grinFunctions grin, Aliased _ name <- funcDefArgs func ]++ppGrin :: Grin -> Doc+ppGrin grin+    = text "Nodes:" <$$>+      vsep (map (ppNodeDef qualMap) (grinNodes grin)) <$$>+      (text "CAFs:") <$$>+      vsep (map (ppCAF qualMap) (grinCAFs grin)) <$$>+      (text "Functions:") <$$>+      vsep (map (ppFuncDef qualMap) (grinFunctions grin))+    where qualMap = grinQualMap grin++ppNodeDef :: QualMap -> NodeDef -> Doc+ppNodeDef qual (NodeDef name nodeType args)+    = text "node" <+> ppNodeType setAnchor qual nodeType 0 name <+> hsep (map ppType args)++ppType PtrType  = (text "*")+ppType WordType = (text "#")++ppNodeType def qual ConstructorNode 0 name  = char 'C' <> ppRenamed def qual name+ppNodeType def qual ConstructorNode n name  = char 'P' <> int n <> ppRenamed def qual name+ppNodeType def qual FunctionNode 0 name = char 'F' <> ppRenamed def qual name+ppNodeType def qual FunctionNode n name = char 'P' <> int n <> ppRenamed def qual name++ppRenamed def qual (Aliased n var) -- = pretty var <> if Map.findWithDefault False var qual then char '_' <> int n else empty+    = def n (read (show var))+ppRenamed def qual (Anonymous n)+    = def n ('x':show n)+ppRenamed def qual (Builtin p)     = char '@' <> pretty p+ppRenamed def qual (External e)    = parens (text "foreign" <+> text e)++ppCAF :: QualMap -> CAF -> Doc+ppCAF qual (CAF name value)+    = ppRenamed setAnchor qual name <+> equals <+> ppValue linkToAnchor qual value++ppFuncDef :: QualMap -> FuncDef -> Doc+ppFuncDef qual (FuncDef name args body)+    = hang (hsep (ppRenamed setAnchor qual name : map (ppRenamed setAnchor qual) args) <+> equals) 2+           ((ppBeginExpression qual body))++ppBeginExpression :: QualMap -> Expression -> Doc+ppBeginExpression qual e@(_ :>>= _)+    = (text "do" <+> ppExpression qual e)+ppBeginExpression qual e = ppExpression qual e++ppExpression :: QualMap -> Expression -> Doc+ppExpression qual (Unit value) = text "unit" <+> ppValue linkToAnchor qual value+ppExpression qual (Case value alts)+    = hang (text "case" <+> ppValue linkToAnchor qual (Variable value) <+> text "of") 2+           (vsep (map (ppAlt qual) alts))+ppExpression qual (Application fn args)+    = hsep (ppRenamed linkToAnchor qual fn:map (ppRenamed linkToAnchor qual) args)+ppExpression qual (Store v)+    = text "store" <+> ppValue linkToAnchor qual v+ppExpression qual (a :>> c)+    = ppExpression qual a <$$>+      ppExpression qual c+ppExpression qual (a :>>= b :-> c)+    = (ppValue setAnchor qual (Variable b) <+> text "<-" <+> (ppBeginExpression qual a)) <$$>+      ppExpression qual c++ppAlt qual (value :> exp) = hang (ppValue setAnchor qual value) 2+                                 (text "->" <+> (ppBeginExpression qual exp))++ppValue def qual (Node name nodeType missing args)+    = parens (hsep (ppNodeType linkToAnchor qual nodeType missing name : map (ppRenamed def qual) args))+ppValue def qual (Vector vs) = brackets (hsep (map (ppRenamed def qual) vs))+ppValue def qual (Hole size) = parens (text "@hole" <+> hsep (replicate size (char '_')))+ppValue def qual Empty = text "()"+ppValue def qual (Lit lit) = ppLit lit+ppValue def qual (Variable variable) = ppRenamed def qual variable++ppLit (Lint i) = integer i+ppLit (Lrational r) = text (show r)+ppLit (Lchar char) = text (show char)+ppLit (Lstring string) = text (show string)++++linkToAnchor ident var+    = zeroWidthText ("<a href=\"#"++ show ident ++"\">") <> text var <> zeroWidthText "</a>"++setAnchor ident var+    = zeroWidthText ("<a name=\""++ show ident ++"\">") <> text var <> zeroWidthText "</a>"+
− src/Grin/Interpret.hs 
@@ -1,190 +0,0 @@-module Grin.Interpret(evaluate) where--import StringTable.Atom-import Support.CanType-import Char-import CharIO-import Control.Monad.Identity-import C.Prims-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 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 
@@ -1,214 +0,0 @@-{-# LANGUAGE CPP #-}-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.FreeVars-import Support.Transform-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!"--dumpGrin pname grin = do-    let fn = optOutName options ++ "_" ++ pname ++ ".grin"-    --putErrLn $ "Writing: " ++ fn-    h <- openFile fn  WriteMode-    (argstring,sversion) <- getArgString-    hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]-    hPrintGrin h grin-    hClose h-    {-wdump FD.Grin $ do-        putErrLn $ "v-- " ++ pname ++ " Grin"-        printGrin grin-        putErrLn $ "^-- " ++ pname ++ " Grin"-}---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>>>"-#if BASE4-        putErrLn (show (e::SomeException))-#else-        putErrLn (show e)-#endif-        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)---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 = fail $ "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@(App fn [v,a] t) | fn == funcApply = do-        [v',a'] <- mapM tcVal [v,a]-        if v' == TyNode then return t-         else fail $ "App apply arg doesn't match: " ++ show ap-    f ap@(App fn [v] t) | fn == funcApply = do-        v' <- tcVal v-        if v' == TyNode then return t-         else fail $ "App apply arg doesn't match: " ++ show ap-    f ap@(App fn [v] t) | fn == funcEval = do-        v' <- tcVal v-        if v' == tyINode then return t-         else fail $ "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-                fail $ "App: arguments do not match: " ++ show (a,as',t')-         else fail $ "App: results do not match: " ++ show (a,t,(as',t'))-    f (Store v) = do-        t <- tcVal v-        return [TyPtr t]-    f Alloc { expValue = v } = do-        t <- tcVal v-        return [TyPtr t]-    f (Return v) = mapM tcVal v-    f (Fetch v) = do-        (TyPtr t) <- tcVal v-        return [t]-    f (Error _ t) = return t-    f e@(Update w v) = do-        (TyPtr t) <- tcVal w-        t' <- tcVal v-        same (show e) t t'-        return []-    f (Case _ []) = fail "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-}--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 -> fail $ "variable not in scope: " ++ show e-    f (Lit _ t) = return t-    f Unit = return TyUnit-    f (Const t) = do-        v <- f t-        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-            fail $ "NodeC: arguments do not match " ++ show n ++ show (as'',as')-    f (Item _ t) = return t--
+ src/Grin/Lowering/Apply.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+module Grin.Lowering.Apply+    ( lower+    ) where++import CompactString+import Grin.Types++import Data.Monoid+import Control.Monad.Writer+import Control.Monad.State+++lower :: Grin -> Grin+lower grin+    = case runState (execWriterT (lowerGrin grin)) (grinUnique grin) of+        ((newDefs),unique) -> grin { grinUnique    = unique+                                   , grinFunctions = appEndo newDefs [] }++++type Lower a = WriterT (Endo [FuncDef]) (State Int) a++lowerGrin :: Grin -> Lower ()+lowerGrin grin+    = mapM_ lowerFuncDef (grinFunctions grin)++lowerFuncDef :: FuncDef -> Lower ()+lowerFuncDef def+    = do body <- lowerExpression (funcDefBody def)+         tell $ Endo $ \lst -> def{funcDefBody = body}:lst++lowerExpression :: Expression -> Lower Expression+lowerExpression (e :>>= v :-> t)+    = do e' <- lowerExpression e+         t' <- lowerExpression t+         return (e' :>>= v :-> t')+lowerExpression (e :>> t)+    = do e' <- lowerExpression e+         t' <- lowerExpression t+         return (e' :>> t')+lowerExpression (Application fn args)+    = do return $ Application fn args+lowerExpression (Case v alts)+    = do alts' <- mapM lowerAlt alts+         return $ Case v alts'+lowerExpression (Store v)+    = liftM Store (lowerValue v)+lowerExpression (Unit v)+    = liftM Unit (lowerValue v)++lowerAlt :: Alt -> Lower Alt+lowerAlt (v :> e)+    = do e' <- lowerExpression e+         return (v :> e')+++lowerValue :: Value -> Lower Value+lowerValue (Node (Builtin "evalApply") FunctionNode 0 [a,b])+    = do name <- newApplyFunction+         return $ Node name FunctionNode 0 [a,b]+lowerValue (Node (Builtin "evalApply") _ _ _)+    = error "Grin.Lowering.Apply.lowerValue: Weird apply."+lowerValue (Node name con missing args)+    = do return $ Node name con missing args+lowerValue (Lit lit)    = return $ Lit lit+lowerValue (Vector vs)  = return $ Vector vs+lowerValue (Variable v) = return $ Variable v+lowerValue (Hole size)  = return $ Hole size+lowerValue (Empty)      = return Empty+++newApplyFunction+    = do name <- newVariable "apply"+         fnArg <- newVariable "fn"+         valArg <- newVariable "val"+         fn'Arg <- newVariable "fn'"+         tell $ Endo $ \lst -> FuncDef { funcDefName = name+                                       , funcDefArgs = [fnArg, valArg]+                                       , funcDefBody = Application (Builtin "eval") [fnArg] :>>= fn'Arg :-> Application (Builtin "apply") [fn'Arg, valArg]+                                       } : lst+         return name++newVariable :: CompactString -> Lower Renamed+newVariable alias+    = do u <- get+         put (u+1)+         return $ Aliased u alias++
+ src/Grin/Lowering/GHCism.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings, PatternGuards #-}+{- |+  The External Core output from GHC suffers from many GHCisms and the direct+  translation to GRIN results in incorrect code.+  This module clears out GHC specific patterns and returns GRIN code fit for use.+  CAUTION: This pass MUST be run exactly once from Grin.FromCore.+           Any deviation will mess things up.+-}+module Grin.Lowering.GHCism+    ( lower+    ) where++import CompactString+import Grin.Types++import Control.Monad.State+import Control.Monad.Reader+import qualified Data.Map as Map++lower :: Map.Map CompactString Renamed -> Grin -> Grin+lower scope grin+    = case runState (runReaderT (lowerGrin grin) emptyScope) (grinUnique grin) of+        (newGrin, unique) -> newGrin{grinUnique = unique}+    where emptyScope = Scope { scope = scope }++data Scope = Scope { scope :: Map.Map CompactString Renamed }+type Lower a = ReaderT Scope (State Int) a++lowerGrin :: Grin -> Lower Grin+lowerGrin grin+    = do defs <- mapM lowerFuncDef (grinFunctions grin)+         return grin{grinFunctions = defs}++lowerFuncDef :: FuncDef -> Lower FuncDef+lowerFuncDef def+    = do body <- lowerExpression (funcDefBody def)+         return def{funcDefBody = body}++lowerExpression :: Expression -> Lower Expression+lowerExpression (e :>>= lam)+    = do e' <- lowerExpression e+         lam' <- lowerLambda lam+         return $ e' :>>= lam'+lowerExpression (e :>> f)+    = do e' <- lowerExpression e+         f' <- lowerExpression f+         return $ e' :>> f'+lowerExpression (Application (Builtin fn) [a,b]) | Just renamed <- lookup fn renamedOpts+    = lowerExpression (Application (Builtin renamed) [a,b])+lowerExpression (Application (Builtin fn) [a,b]) | fn `elem` [">=#",">#","==#","<=#","<#"]+    = do tnode <- lookupNode $ fromString "ghc-prim:GHC.Bool.True"+         fnode <- lookupNode $ fromString "ghc-prim:GHC.Bool.False"+         v <- newVariable+         return $ Application (Builtin fn) [a,b] :>>= v :->+                  Case v [Lit (Lint 0) :> Unit (Node fnode ConstructorNode 0 [])+                         ,Lit (Lint 1) :> Unit (Node tnode ConstructorNode 0 [])]++-- MVars+lowerExpression (Application (Builtin "newMVar#") [realWorld])+    = do v <- newVariable+         return $ Store Empty :>>= v :-> Unit (Vector [realWorld, v])+lowerExpression (Application (Builtin "putMVar#") [ptr, val, realWorld])+    = return $ Application (Builtin "update") [ptr, val] :>> Unit (Variable realWorld)+lowerExpression (Application (Builtin "takeMVar#") [ptr, realWorld])+    = do v <- newVariable+         return $ Application (Builtin "fetch") [ptr] :>>= v :-> Unit (Vector [realWorld, v])++-- MutVars++lowerExpression (Application (Builtin "newMutVar#") [val,realWorld])+    = do v <- newVariable+         return $ Store (Variable val) :>>= v :-> Unit (Vector [realWorld, v])+lowerExpression (Application (Builtin "writeMutVar#") [ptr, val, realWorld])+    = return $ Application (Builtin "update") [ptr, val] :>> Unit (Variable realWorld)+lowerExpression (Application (Builtin "readMutVar#") [ptr, realWorld])+    = do v <- newVariable+         return $ Application (Builtin "fetch") [ptr] :>>= v :-> Unit (Vector [realWorld, v])++lowerExpression (Application (Builtin "realWorld#") [])+    = return $ Unit Empty -- FIXME: Use a special RealWorld value?+lowerExpression (Application (Builtin "int2Word#") [v])+    = return $ Unit (Variable v)+lowerExpression (Application (Builtin "word2Int#") [v])+    = return $ Unit (Variable v)+lowerExpression (Application (Builtin "plusAddr#") [a,b])+    = return $ Application (Builtin "+#") [a,b]+lowerExpression (Application (Builtin "eqAddr#") [a,b])+    = lowerExpression $ Application (Builtin "==#") [a,b]+--lowerExpression (Application (Builtin fn) [a]) | fn `elem` ["chr#", "ord#"]+--    = return $ Unit (Variable a)++lowerExpression (Application (Builtin "raiseIO#") [exp, realWorld])+    = return $ Application (Builtin "raise#") [exp]++lowerExpression (Application (Builtin "catch#") [fn, handler, realworld])+    = do v <- newVariable+         return $ Application (Builtin "eval") [fn] :>>= v :-> Application (Builtin "apply") [v, realworld]+lowerExpression (Application (Builtin "blockAsyncExceptions#") [fn, realworld])+    = do v <- newVariable+         return $ Application (Builtin "eval") [fn] :>>= v :-> Application (Builtin "apply") [v, realworld]+lowerExpression (Application (Builtin "unblockAsyncExceptions#") [fn, realworld])+    = do v <- newVariable+         return $ Application (Builtin "eval") [fn] :>>= v :-> Application (Builtin "apply") [v, realworld]++lowerExpression (Application fn vs)+    = return $ Application fn vs+lowerExpression (Case scrut alts)+    = do alts' <- mapM lowerAlt alts+         return $ Case scrut alts'+lowerExpression (Store v)+    = return $ Store v+lowerExpression (Unit v)+    = return $ Unit v++lowerLambda :: Lambda -> Lower Lambda+lowerLambda (v :-> e)+    = do e' <- lowerExpression e+         return $ v :-> e'+lowerAlt :: Alt -> Lower Alt+lowerAlt (v :> e)+    = do e' <- lowerExpression e+         return $ v :> e'+++renamedOpts = [ ("gtChar#", ">#")+              , ("geChar#", ">=#")+              , ("ltChar#", "<#")+              , ("leChar#", "<=#")+              , ("eqChar#", "==#")+              ]++++lookupNode :: CompactString -> Lower Renamed+lookupNode name+    = do m <- asks scope+         case Map.lookup name m of+           Just name -> return name+           Nothing   -> error $ "Couldn't find node: " ++ show name++newVariable :: Lower Renamed+newVariable+    = do u <- get+         put (u+1)+         return $ Anonymous u+
− src/Grin/NodeAnalyze.hs 
@@ -1,294 +0,0 @@---- 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(forM, forM_, when)-import Control.Monad.RWS(MonadWriter(..), RWS(..))-import Data.Monoid-import Data.Maybe-import qualified Data.Map as Map-import qualified Data.Set as Set--import Support.FreeVars-import Support.CanType-import StringTable.Atom-import IO-import Grin.Grin hiding(V)-import Grin.Simplify-import Grin.Noodle-import Util.UnionSolve-import Util.Gen------data NodeType =-    WHNF         -- ^ guarenteed to be a WHNF-    | LazyWHNF   -- ^ WHNF or an indirection to 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'---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 (TyPtr TyNode) = 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)-        grin = renameUniqueGrin grin'-        docaf (v,tt) | True = tell $ Right top `equals` Left (V (Vr v) (TyPtr TyNode))-                     | otherwise = return ()-    --putStrLn "----------------------------"-    --print cs-    --putStrLn "----------------------------"-    -- putStrLn "-- NodeAnalyze"-    (rm,res) <- solve (const (return ())) cs-    --(rm,res) <- solve putStrLn cs-    let cmap = Map.map (fromJust . flip Map.lookup res) rm-    --putStrLn "----------------------------"-    --mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList rm)-    --putStrLn "----------------------------"-    --mapM_ print (Map.elems res)-    --putStrLn "----------------------------"-    --hFlush stdout-    --exitWith ExitSuccess-    nfs <- mapM (fixupFunc cmap) (grinFuncs grin)-    return $ setGrinFunctions nfs grin---data Todo = Todo Bool [V] | TodoNothing--doFunc :: (Atom,Lam) -> M ()-doFunc (name,arg :-> body) = ans where-    -- 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 v TyNode = tell $ Left (vr v TyNode) `equals` Right (N WHNF Top)-    zVar v t = tell $ Left (vr v t) `equals` Right top-    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 $ Left (fa name i vt) `equals` Left (vr v vt)-        fn (Todo True [ fr name i t | i <- naturals | t <- rts ]) body-    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 v vt-            gn TodoNothing x-            f rest-        f body = gn ret body-    isfn _ x y | not (isGood x) = mempty-    isfn (Todo True  _) x y = Left x `equals` y-    isfn (Todo False _) 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 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 -> 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 (App { expFunction = fn, expArgs = [x] }) | fn == funcEval = do-            dres [Right (N WHNF Top)]-        f (App { expFunction = fn, expArgs = [x], expType = ty }) | fn == funcApply = do-            convertVal x-            dunno ty-        f (App { expFunction = fn, expArgs = [x,y], expType = ty }) | fn == funcApply = do-            convertVal x-            convertVal y-            dunno ty-        f (App { expFunction = fn, expArgs = vs, expType = ty }) = do-            vs' <- mapM convertVal vs-            forMn_ (zip vs vs') $ \ ((tv,v),i) -> when (isGood tv) $ 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) -> when (isGood tv) $ do-                tell $ v `islte` Left (fa fn i (getType tv))-            dres [Left $ fr fn i t | i <- [ 0 .. ] | t <- ty ]-        f (Return x) = do-            ww' <- mapM convertVal x-            dres ww'-        f (Store w) | TyNode == getType w = do-            ww <- convertVal w-            dres [ww]-        f (Store w) = do-            ww <- convertVal w-            dunno [TyPtr (getType w)]-        f (Fetch w) | tyINode == getType w = do-            ww <- convertVal w-            --dres [ww]-            dres [Right (N WHNF Top)]-        f (Fetch w) | TyPtr tyINode == getType w = do-            dres [Right top]-        f Error {} = dres []-        f Prim { expArgs = as } = mapM_ convertVal as-        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]---            dres [v']---        f NewRegion { expLam = _ :-> body } = fn ret body-        f (Update (Var vname ty) v) | ty == TyPtr TyNode  = do-            v' <- convertVal v-            tell $ Left (vr vname ty) `isgte` v'-            dres []-        f (Update (Var vname ty) v) | ty == TyPtr (TyPtr TyNode)  = do-            v' <- convertVal v-            dres []-        f (Update v1 v)  = do-            v' <- convertVal v-            v' <- convertVal v1-            dres []-{-        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---        f _ = dres []---    convertVal (Const (NodeC t _)) = return $ Right (N WHNF (Only $ Set.singleton t))-    convertVal (Const _) = return $ Right (N WHNF Top)-    convertVal (NodeC t vs) = case tagUnfunction t of-        Nothing -> 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) (TyPtr TyNode))-            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----fixupFunc cmap (name,l :-> body) = fmap (\b -> (name, l :-> b)) (f body) 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-        _ -> fail "lupVar"-    lupVar _ = fail "lupVar"-    f a@App { expFunction = fn, expArgs = [arg] } | fn == funcEval, Just n <- lupVar arg = case n of-        N WHNF _ -> do-                --putStrLn $ "NA-EVAL-WHNF-" ++ show fn-                return (Fetch arg)-        _ -> return a-    f e = mapExpExp f e-
− src/Grin/Noodle.hs 
@@ -1,238 +0,0 @@-module Grin.Noodle where---- various routines for manipulating and exploring grin code.--import Control.Monad.Writer-import Data.Monoid-import qualified Data.Set as Set--import Support.FreeVars-import StringTable.Atom(Atom())-import Options(flint)-import C.Prims-import Util.Gen-import Grin.Grin-import Support.CanType-import Debug.Trace---modifyTail :: Lam -> Exp -> Exp-modifyTail lam@(_ :-> lb) te = f mempty te where-    lamFV = freeVars lam :: Set.Set 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 `Set.union` Set.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 `Set.member` lf = App a as (getType lb)-    f lf e = e :>>= lam-    g lf (p :-> e) | flint && not (Set.null $ Set.intersection (freeVars p) lamFV) = error "modifyTail: lam floated inside bad scope"-    g lf (p :-> e) = p :-> f lf e---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 (Return vs) = return Return `ap` mapM g vs-    f (Prim x vs t) = return (Prim x) `ap` mapM g vs `ap` return t-    f (Store v) = return Store `ap` g v-    f e@Alloc { expValue = v, expCount = c } = do-        v <- g v-        c <- g c-        return e { expValue = v, expCount = c }-    f (Fetch v) = return Fetch `ap` g v-    f (Update a b) = return Update `ap` g a `ap` g b-    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-        mapExpLam g l { expBody = b }-}-    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 mempty 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 `Set.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 `Set.union` Set.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-----isOmittable (Fetch {}) = True-isOmittable (Return {}) = True-isOmittable (Store x) | getType x /= TyNode = False-isOmittable (Store {}) = True-isOmittable Prim { expPrimitive = aprim } = aprimIsCheap 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 Update {} = True-isErrOmittable (e1 :>>= _ :-> e2) = isErrOmittable e1 && isErrOmittable e2-isErrOmittable (Case x ds) = all isErrOmittable [ e | _ :-> e <- ds ]-isErrOmittable x = isOmittable x------ collect tail called, 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 :>>= y) = do-            xs <- cfunc e-            tell xs-            clfunc y-        cfunc (App a _ _) = return (Set.singleton a)-        cfunc (Case _ as) = do-            rs <- mapM clfunc as-            return (mconcat rs)-{-        cfunc Let { expFuncCalls = (tail,nonTail) } = do-            tell nonTail-            return tail-}-        cfunc Fetch {} = return mempty-        cfunc Error {} = return mempty-        cfunc Prim {} = return mempty-        cfunc Return {} = return mempty-        cfunc Store {} = return mempty-        cfunc Update {} = return mempty-        cfunc Alloc {} = return mempty---        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 = error "grinLet not defined"{-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 Set.\\ myDefs, nonTail Set.\\ myDefs),-            expNonNormal = notNormal,-            expIsNormal = Set.null notNormal-            } where-    (tail,nonTail) = mconcatMap collectFuncs (body : map (lamExp . funcDefBody) defs)-    notNormal =  nonTail `Set.intersection` (Set.fromList $ map funcDefName defs)-    myDefs = Set.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 mempty 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 `Set.member` lf = return ()-{-    f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where-        nlf = lf `Set.union` Set.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--
− src/Grin/Optimize.hs 
@@ -1,210 +0,0 @@--module Grin.Optimize(grinPush,grinSpeculate) where--import Control.Monad.State-import List-import qualified Data.Set as Set--import StringTable.Atom-import C.Prims-import Grin.Grin-import Grin.Noodle-import Stats hiding(null)-import Support.CanType-import Support.FreeVars-import Util.Graph-import Util.SetLike-import Options (verbose)--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 = (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' = 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 = Set.fromList (map tagFlipFunction specs)-    let f (a,l) = mapBodyM h l  >>= \l' -> return (a,l')-        h (Store (NodeC t xs)) | t `member` sset = do-            let t' = tagFlipFunction t-            mtick $ "Optimize.speculate.store.{" ++ show t'-            return (App t' xs [TyNode] :>>= [n1] :-> Store n1)---        h (Update v (NodeC t xs)) | not (isMutableNodeTag t), t `member` sset = do---            let t' = tagFlipFunction t---            mtick $ "Optimize.speculate.update.{" ++ show t'---            return (App t' xs [TyNode] :>>= [n1] :-> Update v 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 Store {} = True-    isSpeculatable (x :>>= _ :-> y) = isSpeculatable x && isSpeculatable y-    isSpeculatable (Case e as) = all isSpeculatable [ e | _ :-> e <- as]-    isSpeculatable Prim { expPrimitive = APrim p _ } = primIsConstant p-    isSpeculatable _ = False----
+ src/Grin/Optimize/Simple.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Grin.Optimize.Simple+    ( optimize+    ) where++import Grin.Types++import Control.Monad.Reader+import qualified Data.Map as Map++++newtype Opt a = Opt {unOpt :: Reader Subst a}+    deriving (MonadReader Subst, Monad)+type Subst = Map.Map Renamed Renamed+++optimize :: Grin -> Grin+optimize grin+    = grin{ grinFunctions = map simpleFuncDef (grinFunctions grin)}+++simpleFuncDef :: FuncDef -> FuncDef+simpleFuncDef def+    = def{ funcDefBody = runReader (unOpt (simpleExpression (funcDefBody def))) Map.empty }++simpleExpression :: Expression -> Opt Expression+simpleExpression (Unit (Variable v1) :>>= v2 :-> t)+    = do v1' <- doSubst v1+         subst v2 v1' (simpleExpression t)+simpleExpression ((a :>>= b :-> c) :>>= d)+    = simpleExpression (a :>>= b :-> c :>>= d)+simpleExpression ((a :>>= b :-> c) :>> d)+    = simpleExpression (a :>>= b :-> c :>> d)+simpleExpression ((a :>> b) :>>= c)+    = simpleExpression (a :>> b :>>= c)+simpleExpression ((a :>> b) :>> c)+    = simpleExpression (a :>> b :>> c)+simpleExpression (Unit Empty :>> c)+    = simpleExpression c+simpleExpression (a :>> b)+    = do a' <- simpleExpression a+         b' <- simpleExpression b+         return (a' :>> b')+simpleExpression (a :>>= b :-> c)+    = do a' <- simpleExpression a+         c' <- simpleExpression c+         return (a' :>>= b :-> c')+simpleExpression (Application fn values)+    = liftM (Application fn) $ doSubsts values+simpleExpression (Store v)+    = liftM Store $ simpleValue v+simpleExpression (Unit value)+    = liftM Unit (simpleValue value)+simpleExpression (Case var [Variable v :> alt])+    = simpleExpression (Unit (Variable var) :>>= v :-> alt)+simpleExpression (Case var alts) | and [ case alt of Unit ret -> ret == cond; _ -> False | cond :> alt <- alts]+    = simpleExpression (Unit (Variable var))+simpleExpression (Case val alts)+    = do val' <- doSubst val+         alts' <- mapM simpleAlt alts+         return $ Case val' alts'+++simpleAlt :: Alt -> Opt Alt+simpleAlt (v :> e) = do e' <- simpleExpression e+                        return (v :> e')++++simpleValue :: Value -> Opt Value+simpleValue (Variable v)+    = liftM Variable $ doSubst v+simpleValue (Node name ty missing args)+    = liftM (Node name ty missing) $ doSubsts args+simpleValue (Vector vs)+    = liftM Vector $ doSubsts vs+simpleValue v@Lit{}  = return v+simpleValue v@Hole{} = return v+simpleValue v@Empty  = return v++doSubst :: Renamed -> Opt Renamed+doSubst var+    = asks $ \m -> case Map.lookup var m of+                     Nothing     -> var+                     Just newVar -> newVar++doSubsts :: [Renamed] -> Opt [Renamed]+doSubsts = mapM doSubst++subst :: Renamed -> Renamed -> Opt a -> Opt a+subst name value = local $ Map.insert name value+
+ src/Grin/Pretty.hs view
@@ -0,0 +1,96 @@+-- TODO: Use unicode for the symbols.+module Grin.Pretty+    ( ppGrin+    , ppExpression+    ) where++import CompactString+import Grin.Types++import Text.PrettyPrint.ANSI.Leijen++import qualified Data.Map as Map++type QualMap = Map.Map CompactString Bool++grinQualMap :: Grin -> QualMap+grinQualMap grin+    = Map.unionsWith (\_ _ -> True) [nodeMap, funcMap, argsMap]+    where nodeMap = Map.fromListWith (\_ _ -> True) [ (name, False) | NodeDef{nodeName = Aliased _ name} <- grinNodes grin ]+          funcMap = Map.fromListWith (\_ _ -> True) [ (name, False) | FuncDef{funcDefName = Aliased _ name} <- grinFunctions grin ]+          argsMap = Map.fromListWith (\_ _ -> True) [ (name, False) | func <- grinFunctions grin, Aliased _ name <- funcDefArgs func ]++ppGrin :: Grin -> Doc+ppGrin grin+    = dullblue (text "Nodes:") <$$>+      vsep (map (ppNodeDef qualMap) (grinNodes grin)) <$$>+      dullblue (text "CAFs:") <$$>+      vsep (map (ppCAF qualMap) (grinCAFs grin)) <$$>+      dullblue (text "Functions:") <$$>+      vsep (map (ppFuncDef qualMap) (grinFunctions grin))+    where qualMap = grinQualMap grin++ppNodeDef :: QualMap -> NodeDef -> Doc+ppNodeDef qual (NodeDef name nodeType args)+    = text "node" <+> ppNodeType qual nodeType 0 name <+> hsep (map ppType args)++ppType PtrType  = blue (text "*")+ppType WordType = white (text "#")++ppNodeType qual nt n name+    = green (worker qual nt n name)+    where worker qual ConstructorNode 0 name  = char 'C' <> ppRenamed qual name+          worker qual ConstructorNode n name  = char 'P' <> int n <> ppRenamed qual name+          worker qual FunctionNode 0 name = char 'F' <> ppRenamed qual name+          worker qual FunctionNode n name = char 'P' <> int n <> ppRenamed qual name++ppRenamed qual (Aliased n var) = pretty var <> if True || Map.findWithDefault False var qual then char '_' <> pretty n else empty+ppRenamed qual (Anonymous n)   = char 'x' <> pretty n+ppRenamed qual (Builtin p)     = char '@' <> pretty p+ppRenamed qual (External e)    = parens (text "foreign" <+> text e)++ppCAF :: QualMap -> CAF -> Doc+ppCAF qual (CAF name value)+    = ppRenamed qual name <+> equals <+> ppValue qual value++ppFuncDef :: QualMap -> FuncDef -> Doc+ppFuncDef qual (FuncDef name args body)+    = hsep (ppRenamed qual name : map (ppRenamed qual) args) <+> equals <$$>+      indent 2 (ppBeginExpression qual body)++ppBeginExpression :: QualMap -> Expression -> Doc+ppBeginExpression qual e@(_ :>>= _)+    = hang 3 (text "do" <+> ppExpression qual e)+ppBeginExpression qual e = ppExpression qual e++ppExpression :: QualMap -> Expression -> Doc+ppExpression qual (Unit value) = blue (text "unit") <+> ppValue qual value+ppExpression qual (Case value alts)+    = blue (text "case") <+> ppValue qual (Variable value) <+> blue (text "of") <$$>+      indent 2 (vsep (map (ppAlt qual) alts))+ppExpression qual (Application fn args)+    = hsep (ppRenamed qual fn:map (ppRenamed qual) args)+ppExpression qual (Store v)+    = blue (text "store") <+> ppValue qual v+ppExpression qual (a :>> c)+    = ppExpression qual a <$$>+      ppExpression qual c+ppExpression qual (a :>>= b :-> c)+    = ppValue qual (Variable b) <+> text "<-" <+> hang 0 (ppBeginExpression qual a) <$$>+      ppExpression qual c++ppAlt qual (value :> exp) = ppValue qual value <$$>+                            indent 2 (text "->" <+> align (ppBeginExpression qual exp))++ppValue qual (Node name nodeType missing args)+    = parens (hsep (ppNodeType qual nodeType missing name : map (ppRenamed qual) args))+ppValue qual (Vector vs) = brackets (hsep (map (ppRenamed qual) vs))+ppValue qual (Hole size) = parens (text "@hole" <+> hsep (replicate size (char '_')))+ppValue qual Empty = text "()"+ppValue qual (Lit lit) = ppLit lit+ppValue qual (Variable variable) = ppRenamed qual variable++ppLit (Lint i) = integer i+ppLit (Lrational r) = text (show r)+ppLit (Lchar char) = text (show char)+ppLit (Lstring string) = text (show string)
− src/Grin/SSimplify.hs 
@@ -1,235 +0,0 @@-module Grin.SSimplify(simplify) where--import qualified Data.IntSet as IS-import qualified Data.IntMap as IM-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Monoid--import Data.DeriveTH-import Data.Derive.All-import StringTable.Atom-import Grin.Grin-import Grin.Noodle-import Util.Gen-import Util.RWS-import Support.CanType-import Support.FreeVars-import qualified Stats-import Stats(mtick)---- 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 makeMonoid ''SEnv)--newtype SState = SState { usedVars :: IS.IntSet }--data SCol = SCol {-    colStats :: Stats.Stat,-    colFreeVars :: Set.Set Var-    }-$(derive makeMonoid ''SCol)--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 -> Grin-simplify grin =-    let (fs,_,SCol { colStats = stats}) = runRWS fun mempty SState { usedVars = mempty }-        S fun = simpFuncs (grinFunctions grin)-    in 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 Set.\\ freeVars ps }-    (e,col) <- censor f $ listen $ local (env' `mappend`) $ simpExp e-    ps <- mapM (zeroVars (`Set.member` colFreeVars col)) ps-    return (ps :-> e)--simpDone :: Exp -> S Exp-simpDone e = do-    pmap <- asks envPapp-    case e of-        (App fap (Var (V vn) _:fs) ty) | fap == funcApply, Just (tl,gs) <- IM.lookup vn pmap -> do-            (cl,fn) <- tagUnfunction tl-            let ne = if cl == 1 then App fn (gs ++ fs) ty else Return [NodeC (partialTag fn (cl - 1)) (gs ++ fs)]-            mtick $ if cl == 1 then "Simplify.Apply.Papp.{" ++ show tl  else ("Simplify.Apply.App.{" ++ show fn)-            return ne-        _ -> do-            cmap <- asks envCSE-            case Map.lookup e cmap of-                Just (n,e') -> do mtick n; 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 && Set.null (freeVars p `Set.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@(App a [v] _) | a == funcEval =  cse' "Simplify.CSE.eval" [(Fetch v,Return p)]-    f p (Fetch v@Var {}) =  cse' "Simplify.CSE.fetch" [(gEval v,Return p)]-    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] (Store v@Var {})  =  cse' "Simplify.CSE.demote" [(Fetch p,Return [v]),(gEval p,Return [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" [(Fetch 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  (a :>>= (v :-> b)) xs = do-        env <- ask-        f a ((env,v,b):xs)--    -- simple transforms-    f (Fetch (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 (App a [Const n] _) rs | a == funcEval = 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@Const {}]) ((senv,[Var vn _],b):rs) = do-        mtick "Grin.Simplify.Subst.const"-        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 [l]) rs = do-        f (Return [v] :>>= l) 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-        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
− src/Grin/Show.hs 
@@ -1,200 +0,0 @@-module Grin.Show(-    prettyFun,-    prettyVal,-    prettyExp,-    printGrin,-    hPrintGrin,-    graphGrin,-    render-    ) where--import Char-import Control.Monad.Writer-import Data.Maybe-import IO-import Monad-import qualified Data.Map as Map-import qualified Data.Set as Set--import StringTable.Atom-import C.Prims-import Data.Graph.Inductive.Graph(mkGraph)-import Data.Graph.Inductive.Tree-import Doc.Attr-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import Grin.Grin-import Grin.Noodle-import Grin.Val-import Options-import Support.CanType-import Support.FreeVars-import Util.Graphviz-import qualified Cmm.Op as Op-import qualified FlagDump as FD----instance PPrint Doc Val   where-    pprint 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)--attr = if dump FD.Html then html else ansi--bold :: Doc -> Doc-bold = attrBold attr-color n x = attrColor attr n x----color :: Int -> Doc -> Doc---color 1 doc = oob (attr [1]) <> doc <> oob (attr [0])---color c doc = oob (attr [c]) <> doc <> oob (attr [39])--operator = bold . text-keyword = bold . text-tag = color "blue" . text-func = color "lightgreen" . text-prim = color "red" . text---func = text---tag = color 92 . 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 (Fetch v@Var {}) | getType v == tyINode = vl <> keyword "promote" <+> prettyVal v-prettyExp vl (Fetch v) = vl <> keyword "fetch" <+> prettyVal v-prettyExp vl (Error "" _) = vl <> prim "exitFailure"-prettyExp vl (Error s _) = vl <> keyword "error" <+> tshow s-prettyExp vl (App t [v] _) | t == funcEval = vl <> keyword "eval" <+> prettyVal v-prettyExp vl (App t [a] _) | t == funcApply = vl <> keyword "apply" <+> prettyVal a-prettyExp vl (App t [a,b] _) | t == funcApply = vl <> keyword "apply" <+> prettyVal a <+> prettyVal b-prettyExp vl (App a vs _)  = vl <> func (fromAtom a) <+> hsep (map prettyVal vs)-prettyExp vl Prim { expPrimitive = APrim (Op (Op.BinOp bo _ _) _) _, expArgs = [x,y] } | Just (op,_) <- Op.binopInfix bo = vl <> prettyVal x <+> operator op <+> prettyVal y-prettyExp vl Prim { expPrimitive = APrim (Op (Op.BinOp bo _ _) _) _, expArgs = [x,y] } = vl <> prettyVal x <+> char '`' <> tshow bo <> char '`' <+> prettyVal y-prettyExp vl Prim { expPrimitive = APrim (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 (Update x y) = vl <> keyword "update" <+> prettyVal x <+> 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 "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  <+> color "lightgreen" (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"-prettyExp vl Call { expValue = ValPrim ap [] (TyCall Primitive' _ _), expArgs = vs } = vl <> prim (tshow ap) <+> hsep (map prettyVal vs)--{-# NOINLINE prettyVal #-}-prettyVal :: Val -> Doc-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 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 (APrim (Op (Op.BinOp bo _ _) _) _) [x,y] | Just (op,prec) <- Op.binopInfix bo = parens (pprintPrec prec x <+> text op <+> pprintPrec prec y)-    f (APrim (Op (Op.BinOp bo _ _) _) _) [x,y] =  parens $ pprintPrec 1 x <+> char '`' <> tshow bo <> char '`' <+> pprintPrec 1 y-    f aprim xs = pprint aprim <> tupled (map tshow 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 "::" <+> hsep (map (tshow . getType) l)  <+> operator "->" <+> 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 
@@ -1,9 +0,0 @@-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/SimpleCore.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE TemplateHaskell #-}+{-+SimpleCore is a subset of External Core that can more easily be translated to Grin.++We do+ * Hoist out local functions (lets and lambdas)++-}+module Grin.SimpleCore+  ( SimpleModule(..)+  , ModuleIdent+  , moduleIdent+  , SimpleType(..)+  , SimpleDef(..)+  , SimpleExp(..)+  , simpleDefArity+  , Alt(..)+  , Lit(..)+  , coreToSimpleCore+  ) where++import Grin.Types (Variable)+import Grin.SimpleCore.Types+import Language.Core (Ty,Tdef,Vdef(..))+-- TODO: The Language.Core library uses parsec and is fairly slow. We could write+-- TODO: a faster version using Happy.+import qualified Language.Core as Core++import CompactString++import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy.Char8 as L+import Control.Monad.RWS+import Data.List++import Traverse++{-+The data structures for the simplified core is similar to plain core with a few exceptions:+ * Lets always have the form 'let x = fn a b c in'+ * Lambdas have been removed+ * Application chains have been converted to lists of arguments.+-}+++++++++coreToSimpleCore :: Core.Module -> SimpleModule+coreToSimpleCore (Core.Module (pkgname,modname) tdefs vdefs)+    = let (_, simpleDefs) = execRWS (mapM_ vdefToSimpleDef allDefs) emptyScope 0+      in SimpleModule { modulePackage = L.unpack pkgname+                      , moduleName    = L.unpack modname+                      , moduleTypes   = concatMap tdefToSimpleTypes tdefs+                      , moduleDefs    = simpleDefs }+    where allDefs = concatMap (\x -> case x of Core.Nonrec d -> [d]; Core.Rec ds -> ds) vdefs+          emptyScope = Scope { currentScope  = Map.empty+                             , currentModule = (pkgname, modname) }++tdefToSimpleTypes :: Core.Tdef -> [SimpleType]+tdefToSimpleTypes (Core.Data _ _ cdefs) = map cdefToSimpleType cdefs+tdefToSimpleTypes (Core.Newtype{}) = []++cdefToSimpleType :: Core.Cdef -> SimpleType+cdefToSimpleType (Core.Constr qual _ tys) = SimpleType { simpleTypeName = qualToCompact qual+                                                       , simpleTypeArity = length tys }++sdefDeps :: Core.Exp -> [(String, String)]+sdefDeps exp+    = let free = Set.toList $ freeVariables exp+      in nub [ (L.unpack pkg, L.unpack mod)+             | qual@(pkg,mod,_ident) <- free+             , not (L.null pkg)+             , not (L.null mod) ]+++isPrimitiveQual (pkg,mod,_ident)+    = pkg == L.pack "ghczmprim" && mod == L.pack "GHCziPrim"+++++--type ScopeEnv = Map.Map (Core.Qual Core.Id) Renamed+data Scope = Scope { currentScope :: Map.Map (Core.Qual Core.Id) Ty+                   , currentModule :: (Core.Pkgname, Core.Mname) }+type M = RWS Scope [SimpleDef] Int++vdefToSimpleDef :: Core.Vdef -> M ()+vdefToSimpleDef vdef+    = let (args, body) = splitExp (vdefExp vdef)+      in bindVariables args $ vdefToSimpleDef' (qualToCompact (vdefName vdef)) [ qualToCompact var | (var,_ty) <- args ] body++vdefToSimpleDef' :: CompactString -> [CompactString] -> Core.Exp -> M ()+vdefToSimpleDef' name args body+    = do body' <- expToSimpleExp body+         tell [SimpleDef { simpleDefName = name+                         , simpleDefArgs = args+                         , simpleDefBody = body'+                         , simpleDefDeps = sdefDeps body }]+++expToSimpleExp :: Core.Exp -> M SimpleExp+expToSimpleExp (Core.Var (pkg,mod,ident)) | pkg == L.pack "ghczmprim" && mod == L.pack "GHCziPrim"+    = return $ Primitive (qualToCompact (L.empty, L.empty, ident))+expToSimpleExp (Core.Var var)  = do isUnboxed <- varIsStrictPrimitive var+                                    return $ Var (qualToCompact var) isUnboxed+expToSimpleExp (Core.Dcon con) = return $ Dcon (qualToCompact con)+expToSimpleExp (Core.Lit lit)  = return $ Lit $ fromCoreLit lit+expToSimpleExp e@Core.App{}    = let (f,args) = collectApps e+                                 in return App `ap` expToSimpleExp f `ap` mapM expToSimpleExp args+expToSimpleExp (Core.Appt a _) = expToSimpleExp a+expToSimpleExp (Core.Lamt _ e) = expToSimpleExp e+-- We remove lambdas by translating them to let expressions.+expToSimpleExp exp@(Core.Lam (var,ty) _)+    = do newVar <- uniqueQual var+         let def     = Vdef { vdefLocal = False+                            , vdefName  = newVar+                            , vdefType  = Core.Tvar $ error "unknown type" -- Urk.+                            , vdefExp   = exp }+         expToSimpleExp (Core.Let (Core.Nonrec def) (Core.Var newVar))+expToSimpleExp (Core.Let (Core.Nonrec def) e) | defIsStrictPrimitive def+    = bindDef def $+      return (LetStrict (qualToCompact (vdefName def))) `ap` expToSimpleExp (vdefExp def) `ap` expToSimpleExp e+expToSimpleExp (Core.Let (Core.Nonrec def) e)+    = bindDef def $+      do (name, toplevelName, args, arity) <- lambdaLift def+         return (Let name toplevelName args arity) `ap` expToSimpleExp e+expToSimpleExp (Core.Let (Core.Rec defs) e)+    = bindDefs defs $ return LetRec `ap` mapM lambdaLift defs `ap` expToSimpleExp e+expToSimpleExp (Core.Case e bind ty [Core.Adefault cond]) | typeIsStrictPrimitive (snd bind)+    = bindVariable bind $+      return (LetStrict (qualToCompact (fst bind))) `ap` expToSimpleExp e `ap` expToSimpleExp cond+expToSimpleExp (Core.Case e bind ty alts)+    = bindVariable bind $+      do e' <- expToSimpleExp e+         alts' <- mapM altToSimpleAlt alts+         let constr = if typeIsStrictPrimitive (snd bind) then CaseStrict else Case+         return $ constr e' (qualToCompact $ fst bind) alts'+expToSimpleExp (Core.Cast e _ty) = expToSimpleExp e+expToSimpleExp (Core.External target conv ty) = return $ External target conv (tyToFFITypes ty)+expToSimpleExp (Core.DynExternal conv ty)     = return $ DynExternal conv (tyToFFITypes ty)+expToSimpleExp (Core.Label label)             = return $ Label label+expToSimpleExp (Core.Note note e)             = {- return (Note note) `ap` -} expToSimpleExp e++tyToFFITypes :: Core.Ty -> [FFIType]+tyToFFITypes (Core.Tarrow (Core.Tcon con) rest)+    = conToFFIType con : tyToFFITypes rest+tyToFFITypes (Core.Tarrow (Core.Tapp (Core.Tcon state) (Core.Tcon realworld)) ret)+    | state == statezh && realworld == theRealWorld+    = case ret of+        Core.Tapp (Core.Tcon tuple) (Core.Tapp (Core.Tcon state) (Core.Tcon realworld))+            | tuple == z1h && state == statezh && realworld == theRealWorld+          -> [Unit]+        Core.Tapp (Core.Tapp (Core.Tcon tuple) (Core.Tapp (Core.Tcon state) (Core.Tcon realworld))) (Core.Tcon con)+            | tuple == z2h && state == statezh && realworld == theRealWorld+          -> [conToFFIType con]+        _ -> [Invalid]+    where z1h = mkPrimQual "Z1H"+          z2h = mkPrimQual "Z2H"+          statezh = mkPrimQual "Statezh"+          theRealWorld = mkPrimQual "RealWorld"+tyToFFITypes ty = [Invalid] -- error $ "Unrecognized ffi type: " ++ show ty++mkPrimQual name+    = (L.pack "ghczmprim", L.pack "GHCziPrim", L.pack name)++conToFFIType :: Core.Qual Core.Tcon -> FFIType+conToFFIType con+    | con == wordzh = Word+    | con == intzh  = Int+    | con == addrzh = Addr+    | otherwise     = Invalid+    where wordzh = mkPrimQual "Wordzh"+          intzh  = mkPrimQual "Intzh"+          addrzh = mkPrimQual "Addrzh"+++defIsStrictPrimitive :: Vdef -> Bool+defIsStrictPrimitive+    = typeIsStrictPrimitive . vdefType++-- FIXME: This function is incomplete.+typeIsStrictPrimitive :: Core.Ty -> Bool+typeIsStrictPrimitive ty+    = case ty of+        Core.Tcon con -> isPrimitiveQual con+        Core.Tapp a b -> typeIsStrictPrimitive a+        _ -> False++altToSimpleAlt :: Core.Alt -> M Alt+altToSimpleAlt (Core.Acon con _tbinds vbinds e) = let bs = map fst vbinds+                                                  in return (Acon (qualToCompact con) (map qualToCompact bs)) `ap` bindVariables vbinds (expToSimpleExp e)+altToSimpleAlt (Core.Alit lit e)                = return (Alit $ fromCoreLit lit) `ap` expToSimpleExp e+altToSimpleAlt (Core.Adefault e)                = return Adefault `ap` expToSimpleExp e+++++fromCoreLit :: Core.Lit -> Lit+fromCoreLit (Core.Lint int _ty)           = Lint int+fromCoreLit (Core.Lrational rational _ty) = Lrational rational+fromCoreLit (Core.Lchar char _ty)         = Lchar char+fromCoreLit (Core.Lstring string _ty)     = Lstring string++{-+First we make the scope explicit:++let a = \x -> x + b in+->+let a b = \x -> x + b++Then we push the function to the top level:++top-level: let_a b = \x -> x + b+let a = let_a b++We have to do this because functions are represented with tags instead of+function pointers.++++fn n = if n == 0 then [] else Cons (ptr!!n) (fn (n+1))++let_fn ptr n = let_s fn = let_fn ptr+               in x + fn 0+++a = x : a++let_a a x = : x a++-}+lambdaLift :: Core.Vdef -> M (CompactString, CompactString, [Variable], Int)+lambdaLift vdef@Vdef{vdefName = (_pkg,_mod,ident), vdefExp = exp}+    = do (pkg,mod) <- asks currentModule+         scope <- asks currentScope+         unique <- newUnique+         let allFreeVars = freeVariables exp `Set.intersection` Map.keysSet scope+             isRecursive = vdefName vdef `Set.member` allFreeVars+             lambdaScope = Set.toList $ if isCAF then allFreeVars else Set.delete (vdefName vdef) allFreeVars+             isCAF = null args+             (args,body) = splitExp exp+         lambdaScopeTyped <- mapM (\var -> do t <- varType var; return (var, t)) lambdaScope+         let+             realArgs = map qualToCompact (lambdaScope ++ map fst args)+             toplevelName = (pkg,mod,L.pack "@lifted@_" `L.append` ident `L.append` L.pack (show unique))+             selfDef = Core.Case (foldl Core.App (Core.Var toplevelName) (map Core.Var lambdaScope))+                                 (vdefName vdef,vdefType vdef)+                                 (vdefType vdef)+                                 [Core.Adefault body]++         bindVariables (lambdaScopeTyped ++ args) $+           if isCAF || not isRecursive+             then vdefToSimpleDef' (qualToCompact toplevelName) realArgs body+             else vdefToSimpleDef' (qualToCompact toplevelName) realArgs selfDef++         return ( qualToCompact (vdefName vdef)+                , qualToCompact toplevelName+                , map qualToCompact lambdaScope+                , length realArgs )+++noType :: Core.Ty+noType = error "Urk, types shouldn't be needed"++freeVariables :: Core.Exp -> Set.Set (Core.Qual Core.Id)+freeVariables (Core.Var qual)                  = Set.singleton qual+freeVariables (Core.Dcon qual)                 = Set.singleton qual+freeVariables (Core.Lam (var,_ty) e)           = Set.delete var $ freeVariables e+freeVariables (Core.Let (Core.Nonrec def) e)   = freeVariables (Core.Let (Core.Rec [def]) e)+freeVariables (Core.Let (Core.Rec defs) e)     = Set.unions (freeVariables e : map (freeVariables . vdefExp) defs) `Set.difference` bound+    where bound = Set.fromList (map vdefName defs)+freeVariables (Core.Case e (var,_ty) _ alts)+    = freeVariables e `Set.union` Set.delete var (Set.unions (map freeVariablesAlt alts))+freeVariables e = tsum freeVariables e++freeVariablesAlt :: Core.Alt -> Set.Set (Core.Qual Core.Id)+freeVariablesAlt (Core.Acon con _tbinds vbinds e)+    = Set.insert con $ freeVariables e `Set.difference` Set.fromList [ var | (var, _ty) <- vbinds ]+freeVariablesAlt (Core.Alit _lit e)+    = freeVariables e+freeVariablesAlt (Core.Adefault e)+    = freeVariables e+++++bindVariable :: (Core.Qual Core.Id, Ty) -> M a -> M a+bindVariable (var, ty)+    = local $ \scope -> scope{ currentScope = Map.insert var ty (currentScope scope)}++bindVariables :: [(Core.Qual Core.Id, Ty)] -> M a -> M a+bindVariables [] = id+bindVariables (x:xs) = bindVariable x . bindVariables xs++bindDef :: Vdef -> M a -> M a+bindDef def+    = bindVariable (vdefName def, vdefType def)++bindDefs :: [Vdef] -> M a -> M a+bindDefs [] = id+bindDefs (x:xs) = bindDef x . bindDefs xs++varIsStrictPrimitive :: Core.Qual Core.Id -> M Bool+varIsStrictPrimitive var+    = asks $ \st -> case Map.lookup var (currentScope st) of+                      Nothing -> False+                      Just ty -> typeIsStrictPrimitive ty++varType :: Core.Qual Core.Id -> M Ty+varType var+    = asks $ \st -> Map.findWithDefault errMsg var (currentScope st)+    where errMsg = error $ "Couldn't find type for: " ++ show var++newUnique :: M Int+newUnique = do u <- get+               put $! u+1+               return u++uniqueQual :: Core.Qual Core.Id -> M (Core.Qual Core.Id)+uniqueQual (pkg,mod,ident)+    = do u <- newUnique+         return (pkg, mod, ident `L.append` L.pack (show u))+++splitExp :: Core.Exp -> ([(Core.Qual Core.Id,Ty)], Core.Exp)+splitExp (Core.Lam b exp) = let (args,body) = splitExp exp+                                in (b:args, body)+splitExp (Core.Lamt _ exp) = splitExp exp+splitExp (Core.Note _ exp) = splitExp exp+splitExp exp = ([], exp)+++collectApps ::Core.Exp -> (Core.Exp, [Core.Exp])+collectApps = worker []+    where worker acc (Core.App a b)+              = worker (b:acc) a+          worker acc (Core.Appt a t)+              = worker acc a+          worker acc (Core.Note _ a)+              = worker acc a+          worker acc (Core.Cast e _)+              = worker acc e+          worker acc a+              = (a,acc)++++++
+ src/Grin/SimpleCore/DeadCode.hs view
@@ -0,0 +1,75 @@+module Grin.SimpleCore.DeadCode+    ( removeDeadCode+    ) where++import CompactString+import Grin.SimpleCore.Types++import qualified Data.Map as Map+import qualified Data.Set as Set++++removeDeadCode :: [(String,String)] -> [String] -> Map.Map (String,String) SimpleModule -> ([SimpleType], [SimpleDef])+removeDeadCode initialModules entryPoints modules+    = let entryPointsCompact = map fromString entryPoints+          addModules mods entries = entries `Map.union` Map.unions (map (entityMap `find`) mods)+          loop entries seenMods seen ds+              = let (mods,refs) = unzip (map (entries `find`) ds)+                    new  = Set.unions refs `Set.difference` seen+                    seen' = Set.union seen new+                in if Set.null new+                   then ( Set.toList seenMods+                        , seen `Set.union` Set.fromList entryPointsCompact)+                   else loop (addModules (concat mods) entries) (Set.union seenMods (Set.fromList (concat mods)))  seen' (Set.toList new)+          (modDeps, deps) = loop (addModules initialModules Map.empty) (Set.fromList initialModules) Set.empty entryPointsCompact+          neededMods = map (modules `find`) modDeps+          tdefs = concatMap moduleTypes neededMods+          defs = concatMap moduleDefs neededMods+      in ( [ tdef | tdef <- tdefs, simpleTypeName tdef `Set.member` deps ]+         , [ def  | def  <- defs, simpleDefName def `Set.member` deps ]+         )+    where find m k = case Map.lookup k m of+                       Just v  -> v+                       Nothing -> error $ "Couldn't find key: " ++ show k+          entityMap :: Map.Map (String,String) (Map.Map CompactString ([(String,String)], Set.Set CompactString)) +          entityMap = flip Map.map modules $ \smod ->+                      Map.fromList $ [ (simpleDefName def, (simpleDefDeps def, defDependencies def)) | def <- moduleDefs smod ] +++                                     [ (simpleTypeName tdef, ([],Set.empty)) | tdef <- moduleTypes smod]+++defDependencies :: SimpleDef  -> Set.Set CompactString+defDependencies def+    = dependencies (simpleDefBody def) `Set.difference` Set.fromList (simpleDefArgs def)++dependencies :: SimpleExp -> Set.Set CompactString+dependencies (Var var isUnboxed) = Set.singleton var+dependencies Primitive{}= Set.empty+dependencies (Dcon var) = Set.singleton var+dependencies Lit{} = Set.empty+dependencies (App a args) = Set.unions (dependencies a : map dependencies args)+dependencies (Let var toplevel _ _ e)+    = Set.delete var $ Set.insert toplevel $ dependencies e+dependencies (LetRec defs e)+    = let vars      = Set.fromList [ var | (var,_,_,_) <- defs ]+          toplevels = Set.fromList [ toplevel | (_,toplevel,_,_) <- defs ]+      in (dependencies e `Set.union` toplevels) `Set.difference` vars+dependencies (LetStrict name def e)+    = Set.delete name $ dependencies def `Set.union` dependencies e+dependencies (Case e bind alts)+    = Set.delete bind $ Set.unions (dependencies e : map altDependencies alts)+dependencies (CaseStrict e bind alts)+    = Set.delete bind $ Set.unions (dependencies e : map altDependencies alts)+dependencies External{} = Set.empty+dependencies DynExternal{} = Set.empty+dependencies Label{} = Set.empty+dependencies (Note _ e) = dependencies e++altDependencies :: Alt -> Set.Set CompactString+altDependencies (Acon tag args e)+    = Set.insert tag $ dependencies e `Set.difference` Set.fromList args+altDependencies (Alit _ e)+    = dependencies e+altDependencies (Adefault e)+    = dependencies e+
+ src/Grin/SimpleCore/Types.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TemplateHaskell #-}+module Grin.SimpleCore.Types where++import CompactString+import Traverse+import qualified Language.Core as Core+import Control.Monad++import Data.Binary+import Data.DeriveTH++data SimpleModule+    = SimpleModule { modulePackage :: String+                   , moduleName    :: String+                   , moduleTypes   :: [SimpleType]+                   , moduleDefs    :: [SimpleDef]+                   }++type ModuleIdent = (String,String)+moduleIdent mod = (modulePackage mod, moduleName mod)++data SimpleType+    = SimpleType { simpleTypeName  :: CompactString+                 , simpleTypeArity :: Int+                 }++data SimpleDef+    = SimpleDef { simpleDefName :: CompactString+                , simpleDefArgs :: [CompactString]+                , simpleDefBody :: SimpleExp+                , simpleDefDeps :: [(String,String)]+                }+simpleDefArity :: SimpleDef -> Int+simpleDefArity = length . simpleDefArgs++data SimpleExp+    = Var CompactString Bool+    | Primitive CompactString+    | Dcon CompactString+    | Lit Lit+    | App SimpleExp [SimpleExp]+    | Let CompactString CompactString [CompactString] Int SimpleExp+    | LetRec [(CompactString, CompactString, [CompactString], Int)] SimpleExp+    | LetStrict CompactString SimpleExp SimpleExp+    | Case SimpleExp CompactString [Alt]+    | CaseStrict SimpleExp CompactString [Alt]+    | External String String [FFIType]+    | DynExternal String [FFIType]+    | Label String+    | Note String SimpleExp++data FFIType = Word | Int | Addr | Unit | Invalid++data Alt+    = Acon CompactString [CompactString] SimpleExp+    | Alit Lit SimpleExp+    | Adefault SimpleExp++data Lit+    = Lint Integer+    | Lrational Rational+    | Lchar Char+    | Lstring String+    deriving (Show,Eq,Ord)++$(derive makeBinary ''Alt)+$(derive makeBinary ''Lit)+$(derive makeBinary ''FFIType)+$(derive makeBinary ''SimpleExp)+$(derive makeBinary ''SimpleDef)+$(derive makeBinary ''SimpleType)+$(derive makeBinary ''SimpleModule)+++instance Traverse Core.Exp where+    tmapM fn exp = case exp of+        Core.Var{}  -> return exp+        Core.Dcon{} -> return exp+        Core.Lit{}  -> return exp+        Core.App a b -> return Core.App `ap` fn a `ap` fn b+        Core.Appt a t -> return Core.Appt `ap` fn a `ap` return t+        Core.Lam b e -> return (Core.Lam b) `ap` fn e+        Core.Lamt b e -> return (Core.Lamt b) `ap` fn e+        Core.Let vdefg e -> return Core.Let `ap` return vdefg `ap` fn e+        Core.Case e bind ty alts+          -> let mapAlt (Core.Acon qual tbinds vbinds e)+                     = return (Core.Acon qual tbinds vbinds) `ap` fn e+                 mapAlt (Core.Alit lit e)+                     = return (Core.Alit lit) `ap` fn e+                 mapAlt (Core.Adefault e)+                     = return Core.Adefault `ap` fn e+             in return Core.Case `ap` fn e `ap` return bind `ap` return ty `ap` mapM mapAlt alts+        Core.Cast e ty -> return Core.Cast `ap` fn e `ap` return ty+        Core.Note n e  -> return (Core.Note n) `ap` fn e+        Core.External{} -> return exp+        Core.DynExternal{} -> return exp+        Core.Label{} -> return exp+
− src/Grin/Simplify.hs 
@@ -1,696 +0,0 @@-module Grin.Simplify(simplify,renameUniqueGrin) where--import Control.Monad.Writer-import Control.Monad.State-import Control.Monad.Trans-import Control.Monad.RWS-import Data.Monoid-import List hiding (insert,union)-import Maybe-import qualified Data.Map as Map-import qualified Data.Set as Set--import StringTable.Atom-import GenUtil hiding(putErrLn,replicateM_)-import Grin.Grin-import Grin.Noodle-import Grin.Whiz-import Stats hiding(combine)-import Support.CanType-import Support.FreeVars-import Util.Graph-import Util.HasSize-import Util.Inst()-import Util.UniqueMonad-import Util.SetLike-import qualified Util.Seq as Seq-import qualified Util.Histogram as Hist-import Options (verbose)---- perform a number of simple simplifications.--- inline very small and builtin-wrapper functions--- copy propagation--- CSE / constant propagation--- dispose of code unreachable via Error---at_OptSimplifyInline  = toAtom "Optimize.simplify.inline"-at_OptSimplifyCopyProp  = toAtom "Optimize.simplify.copy-propagate"-at_OptSimplifyCopyPropConst  = toAtom "Optimize.simplify.copy-propagate-const"-at_OptSimplifyNodeReduction  = toAtom "Optimize.simplify.node-reduction"-at_OptSimplifyDeadVar  = toAtom "Optimize.simplify.dead-var"-at_OptSimplifyConstApply  = toAtom "Optimize.simplify.const-apply"-at_OptSimplifyConstFetch  = toAtom "Optimize.simplify.const-fetch"-at_OptSimplifyConstEval  = toAtom "Optimize.simplify.const-eval"-at_OptSimplifyTrivialCase  = toAtom "Optimize.simplify.trivial-case"-at_OptSimplifyBadAssignment  = toAtom "Optimize.simplify.bad-assignment"-at_OptSimplifyHoleAssignment  = toAtom "Optimize.simplify.hole-assignment"-at_OptSimplifyConstStore  = toAtom "Optimize.simplify.const-store"-at_OptSimplifyCastLit  = toAtom "Optimize.simplify.cast-lit"-at_OptSimplifyConstUpdate  = toAtom "Optimize.simplify.const-update"-at_OptSimplifyEnumAssignment  = toAtom "Optimize.simplify.enum-assignment"---- contains functions that should be inlined-type SimpEnv = Map.Map Atom (Atom,Lam)---simplify1 :: Stats -> SimpEnv -> (Atom,Lam) -> IO (Atom,Lam)-simplify1 stats env (n,l) = do-    (l,_) <- evalStateT (whiz fn gv f whizState l) mempty-    return (n,l)-    where-    fn _ m = do-        s <- get-        x <- m-        put s-        return x--    f (Case x [d]) = do-        (env,_) <- get-        x <- applySubst env  x-        lift $ tick stats at_OptSimplifyTrivialCase-        return $ (Return [x] :>>= d)-    f x = do-        (env,_) <- get-        x <- applySubstE env  x-        x <- gs x-        inline x-    gs (Update Const {} Var {}) = do-        lift $ tick stats at_OptSimplifyConstUpdate-        gs (Return [])---    gs (Prim Primitive { primAPrim = APrim CCast {} _, primType = (_,nty) } [Lit i _]) = do---        lift $ tick stats at_OptSimplifyCastLit---        return $ Return (Lit i nty)-    gs (Store n) | valIsNF n = do-        lift $ tick stats at_OptSimplifyConstStore-        gs (Return [Const n])---    gs (App a [n@NodeC {},v] typ) | a == funcApply = do---        lift $ tick stats at_OptSimplifyConstApply---        gs (doApply Return True n [v] typ)---    gs (Store (NodeC t [Const x@NodeC {},y])) | Just 1 <- fromBap t = do --  App a [n@NodeC {},v] typ) | a == funcApply = do---        lift $ tick stats "Optimize.simplify.const-lazy-apply"---        gs (doApply Store False x y TyNode)-    gs (App a [Const n] typ) | a == funcEval = do-        lift $ tick stats at_OptSimplifyConstEval-        gs (Return [n])-    gs (Fetch (Const n)) = do-        lift $ tick stats at_OptSimplifyConstFetch-        gs (Return [n])-    gs x = return x-    gv (p,Case x ds) = do-        (env,_) <- get-        x <- applySubst env x-        case ds of-            [] -> error "empty case"-            [d] -> do-                lift $ tick stats at_OptSimplifyTrivialCase-                return $ Just (p,Return [x] :>>= d)-            _ -> return $ Just (p,Case x ds)-    gv ([NodeC t xs],Return [NodeC t' xs']) | t == t' = do-            lift $ tick stats at_OptSimplifyNodeReduction-            gv (xs,Return xs')---    gv (NodeC t xs,Return (NodeC t' [])) |  t' == tagHole = do---            lift $ tick stats at_OptSimplifyHoleAssignment---            gv (Tup xs, Return $ Tup $ Prelude.map (properHole . getType) xs)-    gv ([NodeC t xs],Return [(NodeC t' xs')]) | t /= t' = do-            lift $ tick stats at_OptSimplifyBadAssignment-            gv (xs,Error ("Bad Assignment: " ++ show (t,t')) (map getType xs))-    gv (p,e) = do-        (env,_) <- get-        e <- (applySubstE env e)-        e <- gs e-        case e of-            Return v | all valIsNF v, Just n <- zipWithM varBind' p v -> do-                lift $ tick stats at_OptSimplifyCopyPropConst-                modify (`mappend` (Map.unions n,mempty))-                return Nothing-            Return v | Just n <- zipWithM varBind p v -> do-                lift $ tick stats at_OptSimplifyCopyProp-                modify (`mappend` (Map.unions n,mempty))-                return Nothing-            _ -> do-                e <- inline e-                mz <- getCS (p,e)-                modify (mappend (mempty,mz))-                return $ Just (p,e)-    -- funcMap = Map.fromList $ [  fn | fn <- grinFunctions grin, doInline fn]-    doInline (a,fn)-        --  | 'b':_ <- n, not ("bap" `isPrefixOf` n) = True-        --  | "fInstance@" `isPrefixOf` n = True-        | isSimple (a,fn) = True-        | otherwise = False-      --  where n = fromAtom a-    inline app@(App fn as _)-        | Just (itype,l) <- Map.lookup fn env = do-            lift $ tick stats itype-            return $ Return as :>>= l-        | otherwise = tryCSE app-    inline x = tryCSE x-    tryCSE x = do-        (_,ce) <- get-        case Map.lookup x ce of-            Just v -> do-                lift $ tick stats (cseStat x)-                return v-            Nothing -> return x---    getCS (b,app@(App a [vr@Var {}] _)) | a == funcEval = return $ Map.fromList [(app,Return [b]), (Store b,Return [vr])]-    --getCS (b,app@App{})  = return $ Map.singleton app (Return b)-    --getCS (b@Var {},Store v@(Var _ _)) = return $ Map.singleton (App funcEval [b] TyNode) (Return v)     -- TODO - only works if node stores have always been evaluated.---    getCS (b@Var {},Store v@(NodeC t _)) | not (isMutableNodeTag t), tagIsWHNF t, not (isHoly v) = return $ Map.fromList [(Store v,Return b),(Fetch b,Return v),(App funcEval [b] TyNode,Return v)]---    getCS (b@Var {},Store v@(NodeC t _)) | not (isMutableNodeTag t), not (isHoly v) = return $ Map.fromList [(Store v,Return [b])]-    --getCS (b@Var {},Store v@(NodeC t as)) | Just (0,fn) <- tagUnfunction t = return $ Map.fromList [(Store v,Return b),(App funcEval [b] TyNode, App fn as TyNode :>>= n1 :-> Update b n1 :>>= unit :-> Return n1)]---    getCS (b@Var {},Store v@(NodeC t as)) | Just (0,fn) <- tagUnfunction t = return $ Map.fromList [(Store v,Return b)]---    getCS (b@Var {},Return (Const v)) = return $ Map.fromList [(Fetch b,Return v),(App funcEval [b] TyNode,Return v)]---    getCS (b@Var {},Return v) = return $ Map.fromList [(Return b,Return v), (Store b, Store v), (Fetch b, Fetch v)]-    getCS _ = return mempty-    isHoly (NodeC _ as) | any isValUnknown as = True-    isHoly n = isHole n---cseStat n = toAtom $ "Optimize.simplify.cse." ++ g n where-    g App { expFunction = n } = fromAtom n-    g Fetch {} = "Fetch"-    g Store {} = "Store"-    g _ = "Misc"--doApply ret strict (NodeC t xs) ys typ | Just (n,v) <- tagUnfunction t = case n of-    1 | strict -> (App v (xs ++ ys) typ)-    _ -> ret (NodeC (partialTag v (n - 1)) (xs ++ ys))-doApply _ _ n y typ = error $ show ("doApply", n,y,typ)--doEval n@(NodeC t xs) typ-    | tagIsWHNF t = Return [n]-    | tagIsSuspFunction t = App (tagFlipFunction t) xs typ-doEval n typ = error $ show ("doEval", n,typ)--{--fromBap :: Monad m => Atom -> m Int-fromBap t | 'B':'a':'p':'_':(n:ns) <- fromAtom t, isDigit n = return $ read (n:takeWhile isDigit ns)-fromBap t = fail "not Bap"--}---- This only binds variables to variables-varBind :: Monad m => Val -> Val -> m (Map.Map Var Val)-varBind (Var v t) nv@(Var v' t') | t == t' = return $ Map.singleton v nv-varBind (Lit i t) (Lit i' t') | i == i' && t == t' = return mempty---varBind (Tup xs) (Tup ys) | length xs == length ys  = liftM mconcat $ sequence $  zipWith varBind xs ys-varBind (NodeC t vs) (NodeC t' vs') | t == t' = do-    liftM mconcat $ sequence $  zipWith varBind vs vs'-varBind v r | (getType v) == (getType r)  = fail "unvarBindable"    -- check type to be sure-varBind x y = error $ "varBind: " ++ show (x,y)---- This binds variables to anything-varBind' :: Monad m => Val -> Val -> m (Map.Map Var Val)-varBind' (Var v t) nv | t == getType nv = return $ Map.singleton v nv-varBind' (Lit i t) (Lit i' t') | i == i' && t == t' = return mempty---varBind' (Tup xs) (Tup ys) | length xs == length ys  = liftM mconcat $ sequence $  zipWith varBind' xs ys-varBind' (NodeC t vs) (NodeC t' vs') | t == t' = do-    liftM mconcat $ sequence $  zipWith varBind' vs vs'-varBind' v r | (getType v) == (getType r)  = fail "unvarBind'able"    -- check type to be sure-varBind' x y = error $ "varBind': " ++ show (x,y)--isSimple :: (Atom,Lam) -> Bool-isSimple (fn,x) = f (2::Int) x where-    f n _ | n <= 0 = False-    f n (p :-> a :>>= b ) = (f (n - 1) (p :-> a)) &&  (f (n - 1) b)-    f _ (_ :-> Case {}) = False---    f _ (_ :-> Let {}) = False---    f _ (_ :-> MkCont {}) = False-    f _ _ = True---manifestNodes as = Prelude.map (isManifestNode . lamExp) as--data UnboxingResult = UnboxTup (Atom,[Ty]) | UnboxConst Val-    deriving(Eq,Ord)--isCombinable :: Monad m => Bool -> Exp -> m UnboxingResult-isCombinable postEval e = ans where-    ans = do-        mn <- f (mempty :: Set.Set Atom) e-        equal mn-    equal [] = fail "empty isCombinable"-    equal [x] = return x-    equal (x:y:rs) = if x == y then equal (y:rs) else fail "not equal"-    f lf (Return [z]) | valIsConstant z = return [UnboxConst z]-    f lf (Return [NodeC t xs]) = return [UnboxTup (t,map getType xs)]-    f lf Error {} = return []-    f lf (Case _ ls) = do-        cs <- Prelude.mapM (f lf) [ e | _ :-> e <- ls ]-        return $ concat cs-    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` Set.fromList (map funcDefName defs)-        ans = do-            xs <- mapM (f nlf . lamExp . funcDefBody) defs-            b <- f nlf body-            return (concat (b:xs))-}-    f _ _ = fail "not combinable"------combineLam postEval nty (p :-> e) = p :-> combine postEval nty e where-combine postEval nty exp = editTail nty f exp where-    f (Return v) | all valIsConstant v  = return $ Return []-    f (Return [NodeC t xs]) = return $ Return xs-    f e = fail $ "combine: " ++ show (postEval,nty,e)--editTail :: Monad m => [Ty] -> (Exp -> m Exp) -> Exp -> m Exp-editTail nty mt te = f (mempty :: Set.Set 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` Set.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---isKnown NodeC {} = True-isKnown Lit {} = True-isKnown _ = False--mapExp f (b :-> e) = b :-> f e--sizeLam (b :-> exp) = sizeExp exp-sizeExp (x :>>= y) = sizeExp x + sizeLam y-sizeExp (Case e as) = 1 + sum (map sizeLam as)---sizeExp Let { expDefs = defs, expBody = body } = sizeExp body + sum (map (sizeLam . funcDefBody) defs)---sizeExp MkCont { expCont = l1, expLam = l2 } = 1 + sizeLam l1 + sizeLam l2-sizeExp x = 1--optimize1 ::  Grin -> Bool -> (Atom,Lam) -> StatT IO Lam-optimize1 grin postEval (n,l) = execUniqT 1 (g l) where-    mtick x = do-        lift $ lift $ putStrLn x-        Stats.mtick x-    g (b :-> e) = f e >>= return . (b :->)---    f (Case e as :>>= lam)  | (sizeLam lam - 1) * length as <= 3 = do---        mtick "Optimize.optimize.case-pullin"---        return (Case e (map (mapExp (:>>= lam)) as))---    f (Return t@NodeC {} :>>= v@Var {} :-> Update w v' :>>= lr) | v == v' = do---        mtick "Optimize.optimize.return-update"---        f (Return t :>>= v :-> Update w t :>>= lr)-    f (e :>>= v1 :-> Return v2) | (all isVar v1) && v1 == v2 = do-        mtick "Optimize.optimize.unit-unit"-        f e-    f (Store t :>>= [v] :-> Fetch v' :>>= lr) | v == v' = do-        mtick "Optimize.optimize.store-fetch"-        f (Store t :>>= [v] :-> Return [t] :>>= lr)-    f (Store t :>>= [v@(Var vr _)] :-> Update  v' w :>>= lr) | v == v', vr `notElem` freeVars w = do-        mtick "Optimize.optimize.store-update"-        f (Store w :>>= [v] :-> Return [] :>>= lr)-    f (Update v t :>>= [] :-> Fetch v' :>>= lr) | v == v' = do-        mtick "Optimize.optimize.update-fetch"-        f (Update v t :>>= [] :-> Return [t] :>>= lr)---    f (Return [t@NodeC {}] :>>= v :-> App fa [v',a] typ :>>= lr) | fa == funcApply, v == v' = do---        mtick "Optimize.optimize.return-apply"---        f (Return [t] :>>= v :-> doApply Return True t [a] typ :>>= lr)---    f (Return t@NodeC {} :>>= v :-> App fa [v',a] typ) | fa == funcApply, v == v' = do---        mtick "Optimize.optimize.return-apply"---        f (Return t :>>= v :-> doApply Return True t [a] typ)---    f (Return t@NodeC {} :>>= v :-> App fa [v'] typ :>>= lr) | fa == funcApply, v == v' = do----        mtick "Optimize.optimize.return-apply0"---        f (Return t :>>= v :-> doApply Return True t [] typ :>>= lr)---    f (Return t@NodeC {} :>>= v :-> App fa [v'] typ) | fa == funcApply, v == v' = do---        mtick "Optimize.optimize.return-apply0"---        f (Return t :>>= v :-> doApply Return True t [] typ)---    f (Store t@NodeC {} :>>= v :-> App fa [v'] typ :>>= lr) | not (valIsMutable t), fa == funcEval, v == [v'] = do---        mtick "Optimize.optimize.store-eval"---        f (Store t :>>= v :-> doEval t typ :>>= lr)---    f (Store t@NodeC {} :>>= v :-> App fa [v'] typ) | not (valIsMutable t), fa == funcEval, v == v' = do---        mtick "Optimize.optimize.store-eval"---        f (Store t :>>= v :-> doEval t typ)---    f (Update v t@NodeC {} :>>= [] :-> App fa [v'] typ :>>= lr) | fa == funcEval, v == v' = do---        mtick "Optimize.optimize.update-eval"---        f (Update v t :>>= [] :-> doEval t typ :>>= lr)---    f (Update v t@NodeC {} :>>= [] :-> App fa [v'] typ) | fa == funcEval, v == v' = do---        mtick "Optimize.optimize.update-eval"---        f (Update v t :>>= [] :-> doEval t typ)-    f (Case n as) | isKnown n = do-        knownCase n as-    f (Case n as :>>= lr) | isKnown n = do-        kc <- knownCase n as-        lr' <- g lr-        return (kc :>>= lr')-    f (Return [n] :>>= b :-> Case b' as :>>= lr) | isKnown n, b == [b'] = do-        c <- knownCase n as-        lr' <- g lr-        return (Return [n] :>>= b :-> c :>>= lr')-    f (Return [n] :>>= b :-> Case b' as ) | isKnown n, b == [b'] = do-        kc <- knownCase n as-        return (Return [n] :>>= b :-> kc)-        {--    f (Case x as :>>= [] :-> (Case x' as') :>>= lr) | x == x', not $ any (isVar . lamBind) as = do-        c <- caseCombine x as as'-        f (c :>>= lr)-    f (Case x as :>>= [] :-> (Case x' as')) | x == x', not $ any (isVar . lamBind) as = do-        c <- caseCombine x as as'-        f c-    f (Case x as :>>= b :-> m) | count (/= Just []) (manifestNodes as) <= 1 = do-        mtick "Optimize.optimize.case-pullin"-        f $ Case x [ x :-> (e :>>= b :-> m) |  x :-> e <- as ]-    f (cc@Case {} :>>= v :-> Return v' :>>= [NodeC t as] :-> lr ) | v == v' = do-        mtick "Optimize.optimize.case-hoist-return"-        let (va:_) = [ v | v <- [v1..], not $ v `Set.member` fv ]-            var = Var va TyNode-            fv = freeVars as-            mc = modifyTail ( var :-> Return var :>>=  [NodeC t as] :-> Return as)-        return (mc cc :>>= as :-> Return [NodeC t as] :>>= v :-> lr)-    f (lt@Let { expIsNormal = True } :>>= v :-> Return v' :>>= [NodeC t as] :-> lr ) | v == v' = do-        mtick "Optimize.optimize.let-hoist-return"-        let (va:_) = [ v | v <- [v1..], not $ v `Set.member` fv ]-            var = Var va TyNode-            fv = freeVars as-            mc = modifyTail ( var :-> Return var :>>=  [NodeC t as] :-> Return (as))-        return (mc lt :>>= as :-> Return [NodeC t as] :>>= v :-> lr)-        -}--{-    f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars r `Set.intersection` (Set.fromList $ map funcDefName defs)) = do-        mtick "Optimize.optimize.let-shrink-tail"-        return (updateLetProps lt { expBody = e } :>>= l :-> r)-}---    f lt@(Let { expDefs = defs, expBody = e :>>= l :-> r } :>>= lr) | Set.null (freeVars r `Set.intersect` (Set.fromList $ map funcDefName defs)) = do---        mtick "Optimize.optimize.let-shrink-tail"---        f ((updateLetProps lt { expBody = e } :>>= l :-> r) :>>= lr)-{-    f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars e `Set.intersection` (Set.fromList $ map funcDefName defs)) = do-        mtick "Optimize.optimize.let-shrink-head"-        return (e :>>= l :-> updateLetProps lt { expBody = r })-}--{--    f (Case x as :>>= v@(Var vnum _) :-> rc@(Case v' as') :>>= lr) | v == v', count (== Nothing ) (Prelude.map (isManifestNode . lamExp) as) <= 1, not (vnum `Set.member` freeVars lr) = do-        c <- caseHoist x as v as' (getType rc)-        f (c :>>= lr)-    f (Case x as :>>= v :-> rc@(Case v' as')) | v == v', count (== Nothing ) (Prelude.map (isManifestNode . lamExp) as) <= 1 = do-        ch <- caseHoist x as v as' (getType rc)-        f ch-    -- case unboxing-    f (cs@(Case x as) :>>= lr) | Just (UnboxTup (t,ts)) <- isCombinable postEval cs = do-        mtick $ "Optimize.optimize.case-unbox-node.{" ++ show t-        let fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- as ]-            vs = [ v | v <- [v1..], not $ v `Set.member` fv ]-            vars = [ Var v t | v <- vs | t <- ts ]-        lr <- g lr-        return ((Case x (map (combineLam postEval (tuple ts)) as) :>>= tuple vars  :-> Return (NodeC t vars)) :>>= lr)-    f (cs@(Case x as) :>>= lr) | Just (UnboxConst val) <- isCombinable postEval cs = do-        mtick $ "Optimize.optimize.case-unbox-const.{" ++ show val-        lr <- g lr-        return ((Case x (map (combineLam postEval []) as) :>>= [] :-> Return val) :>>= lr)---    -- let pullin-    f (cs@Let { expIsNormal = True } :>>= lr) |  sizeLTE 1 (filter (/= ReturnError) (getReturnInfo cs)) = do-            mtick "Optimize.optimize.let-pullin"-            return $ modifyTail lr cs-    -- case pullin-    f (cs@Case {} :>>= lr) |  sizeLTE 1 (filter (/= ReturnError) (getReturnInfo cs)) = do-            mtick "Optimize.optimize.case-pullin"-            return $ modifyTail lr cs-  -}--{--    f cs@(Case x as) | postEval && all isEnum [ p | p :-> _ <- as] = do-        mtick "Optimize.optimize.case-enum"-        let fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- as ]-            (va:vb:_vr) = [ v | v <- [v1..], not $ v `Set.member` fv ]-        return (Return x :>>= NodeV va [] :-> Case (Var va TyTag) (Prelude.map (untagPat vb) as))-        -}--    -- hoisting must come last---    f (hexp@Case {} :>>= v@(Var vnum _) :-> rc@(Case v' as') :>>= lr) | v == v', not (vnum `Set.member` freeVars lr) = do---        c <- caseHoist hexp v as' (getType rc)---        lr <- g lr---        return $ c :>>= lr---    f (hexp@Case {} :>>= v@Var {} :-> rc@(Case v' as')) | v == v'  = do---        caseHoist hexp v as' (getType rc)--    -- let unboxing-{-    f (cs@Let {} :>>= lr) | Just comb <- isCombinable postEval cs = do-        lr <- g lr-        case comb of-            UnboxTup (t,ts) -> do-                mtick $ "Optimize.optimize.let-unbox-node.{" ++ show t-                let vs = [ v | v <- [v1..], not $ v `Set.member` fv ]-                    vars = [ Var v t | v <- vs | t <- ts ]-                cpe <- combine postEval ts cs-                return ((cpe :>>= vars  :-> Return [NodeC t vars]) :>>= lr)-            UnboxConst val -> do-                mtick $ "Optimize.optimize.let-unbox-const.{" ++ show val-                cpe <- combine postEval [] cs-                return ((cpe :>>= [] :-> Return [val]) :>>= lr)-       where fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- map funcDefBody (expDefs cs) ]-}----    f (hexp@Let {} :>>= v@(Var vnum _) :-> rc@(Case v' as') :>>= lr) | v == v', not (vnum `Set.member` freeVars lr) = do---        c <- caseHoist hexp v as' (getType rc)---        lr <- g lr---        return $ c :>>= lr---    f (hexp@Let {} :>>= v@Var {} :-> rc@(Case v' as')) | v == v'  = do---        caseHoist hexp v as' (getType rc)--    f (e1 :>>= _ :-> err@Error {}) | isErrOmittable e1 = do-        mtick "Optimize.optimize.del-error"-        return err-    f (e1 :>>= l :-> e2) = do-        e1' <- f e1-        e2' <- f e2-        return (e1' :>>= l :-> e2')-    f (Case x as) = do-       as' <- sequence [ f e >>= return . (b :->)| b :-> e <- as ]-       return $ Case x as'-{-    f Let { expDefs = [fd], expBody = body } | not (funcDefName fd `Set.member` funcTags (funcDefProps fd)), sizeLTE 1 nocc = ans where-        (ne,nocc) = runWriter (c body)-        ans = case nocc of-            [] -> do-                mtick $ "Optimize.let.omitted.{" ++ show (funcDefName fd)-                return ne-            [_] -> do-                mtick $ "Optimize.let.inlined.{" ++ show (funcDefName fd)-                return ne-        c (App a xs _) | a == funcDefName fd = do-            tell [a]-            return $ Return xs :>>= funcDefBody fd-        c e@Let { expDefs = defs } | funcDefName fd `elem` map funcDefName defs = return e-        c e = mapExpExp c e-    f e@Let {} = mapExpExp f e-}-    f e = return e-    notReturnNode (ReturnNode (Just _,_)) = False-    notReturnNode _ = True-    --caseHoist hexp v as' ty | sizeLTE 1 (filter (== Nothing ) (Prelude.map (isManifestNode . lamExp) as))  = do---    caseHoist hexp v as' ty | sizeLTE 1 (filter (\x -> x /= ReturnError && notReturnNode x ) (getReturnInfo hexp))= do---        mtick $ "Optimize.optimize.case-hoist" -- .{" ++ show (Prelude.map (isManifestNode . lamExp) as :: [Maybe [Atom]])---        nic <- f (Case v as')---        --True <- return $ Set.null $ Set.intersection (freeVars nic) (freeVars (map lamBind as) :: Set.Set Var)---        return $ modifyTail ([v] :-> nic) hexp -- Case x [ b :-> e :>>= v :-> Case v as' | b :-> e <- as ]---    caseHoist hexp v as' ty | False && grinPhase grin >= PostDevolve  = do---        let ufuncs = freeVars fbody---            fbody = [v] :-> Case v as'---            cfname = do---                uniq <- newUniq---                let fname = toAtom $ "fjumppoint-" ++ show n ++ "-" ++ show uniq---                if fname `member` (ufuncs :: Set.Set Atom) then cfname else return fname---        fname <- cfname---        let f e@(Return NodeC {}) = e :>>= v :-> Case v as'---            f e@(Return Lit {}) = e :>>= v :-> Case v as'---            f e = e :>>= v :-> App fname [v] ty---            nbody = editTail ty f hexp -- (v :-> App fname [v] (getType $ Case v as')) (Case x as)---        mtick $ "Optimize.optimize.case-hoist-jumppoint.{" ++ show fname -- .{" ++ show (Prelude.map (isManifestNode . lamExp) as :: [Maybe [Atom]])---        return $ grinLet [createFuncDef True fname fbody] nbody---    caseHoist hexp v as' ty = do---       mfc <- f hexp---       fc <- f (Case v as')---       return $ mfc :>>= v :-> fc-    knownCase n@(NodeC t vs) as = do-        mtick $ "Optimize.optimize.known-case-node.{" ++ show t-        --let f [] = error $ "no known case:" ++ show (n,as)-        let f [] =  Error "known-case: No known case" (getType (Case n as))-            f ((v@[Var {}] :-> b):_) = Return [n] :>>= v :-> b-            f (([NodeC t' vs'] :-> b):_) | t == t' =  Return (vs) :>>= vs' :-> b-            -- f ((NodeC t' vs' :-> b):_) | t == t' = let (xs,ys) = unzip [ (Var x t,y) | (x,y@(Var _ t)) <- Map.toList mp] in Return (Tup ys) :>>= Tup xs :-> b-            f (_:as) = f as-        return $ f as-    knownCase n@(Lit l _) as = do-        mtick $ "Optimize.optimize.known-case-lit.{" ++ show n-        let f [] =  Error "known-case: No known case" (getType (Case n as))-            f ((v@[Var {}] :-> b):_) = Return [n] :>>= v :-> b-            f (([Lit l' _] :-> b):_) | l == l' = b-            f (_:as) = f as-        return $ f as---    caseCombine x as as' = do---        mtick $ "Optimize.optimize.case-combine"---        let etags = [ bd | bd@(NodeC t _ :-> _) <- as, t `notElem` [ t | NodeC t _ :-> _ <- as' ] ]---  --          ttags = [ bd | bd@(Tag t:-> _) <- as, t `notElem` [ t | Tag t :-> _ <- as' ] ]---            as'' = Prelude.map f as'--- --           f ([v@Var {}] :-> b) | getType v == TyTag = v :-> Case v ttags :>>= [] :-> b---            f ([v@Var {}] :-> b) = v :-> Case v etags :>>= [] :-> b---            f (n@[(NodeC t _)] :-> b) = case [ a | a@(NodeC t' _ :-> _) <-  as, t == t'] of---                [bind :-> body] -> n :-> Return n :>>= bind :-> body :>>= [] :-> b-----            f (n@[(Tag t)] :-> b) = case [ a | a@(Tag t' :-> _) <-  as, t == t'] of-----                [bind :-> body] -> n :-> Return n :>>= bind :-> body :>>= [] :-> b---            -- f r---        return $ Case x as''--isEnum (NodeC t []) = True-isEnum (Var t TyNode) = True-isEnum _ = False----untagPat _ ([NodeC t []] :-> e) = [Tag t] :-> e---untagPat vb ([v@Var{}] :-> e) = [Var vb TyTag] :-> Return [NodeV vb []] :>>= [v] :-> e---deadVars :: Stats -> (Atom,Lam) -> IO (Atom,Lam)-deadVars stats (n,l) = do-    (x,_) <- (evalStateT (fizz fn gv f whizState l) (mempty :: Set.Set Var) );-    return (n,x)-    where-    fn _ m = m-    f x = do-        uv <- get-        put $ (Set.union uv (freeVars x))-        return x-    gv w@(v, e) | isOmittable e = do-        (uv) <- get-        if  any (`Set.member` uv) (freeVars v) then-            f e >> return (Just w)-         else lift (tick stats at_OptSimplifyDeadVar) >> return Nothing-    gv w@(vs,Case x xs) = do-        uv <- get-        put $ (Set.union uv (freeVars x))-        let used v = any (`Set.member` uv) (freeVars v)-        case partition used vs of-            (_,[]) -> return $ Just w-            (nvs,unused) -> do-                replicateM_ (length unused) $ lift (tick stats "Optimize.simplify.dead-var-case-tup")-                let ml = modifyTail (vs :-> Return nvs)-                return (Just (nvs,ml (Case x xs) ))-    gv w@(_,e) = f e >> return (Just w)----{-# NOINLINE simplify #-}--simplify ::-    Stats     -- ^ stats to update-    -> Grin   -- ^ input grin-    -> IO Grin-simplify stats grin = do-    let postEval = phaseEvalInlined (grinPhase grin)-        fs = grinFuncs grin-        uf = [ ((a,l),collectUsedFuncs l) | (a,l) <- fs ]-        graph = newGraph uf (\ ((a,_),_) -> a) (\ (_,(fi,fd)) -> (if postEval then [] else fi) ++ fd)-        rf = reachable graph (grinEntryPointNames grin)-        reached = Set.fromList $ Prelude.map  (\ ((a,_),_) -> a) rf-        graph' = if postEval then graph else newGraph rf (\ ((a,_),_) -> a) (\ (_,(_,fd)) -> fd)-        (lb,os) = findLoopBreakers ( fromEnum . not . isSimple . fst) (const True) graph'-        loopBreakers = Set.fromList [ a | ((a,_),_) <- lb ]-        indirectFuncs = if postEval then Set.empty else Set.fromList (concat [ fi | (_,(fi,_)) <- rf ])-        hist =  Hist.fromList $ concat [ fd | (_,(_,fd)) <- rf ]-    let opt env a n l = do-                --(_,nl) <- deadVars stats (a,l)-                --(_,nl) <- simplify1 stats env (a,nl)-                --let Identity nl'' = whizExps return nl-                -- putDocM CharIO.putErr (prettyFun (a,nl''))-                --let (nl',stat) = runStatM (optimize1 grin postEval (a,nl''))-                (nl',stat) <- runStatT (optimize1 grin postEval (a,l))-                tickStat stats stat-                return nl'-                {--        opt env a n l = do-            stats' <- Stats.new-            (_,nl) <- deadVars stats (a,l)  -- if the deadVars did not enable any other transformations we don't need to iterate as deadVars is idempotent-            (_,nl) <- simplify1 stats' env (a,nl)-            t <- Stats.getTicks stats'-            case t of-                0 -> return nl-                _ -> do-                    -- when (n > 2) $ Stats.print (show a) stats'-                    Stats.combine stats stats'-                    -- tick stats $ "Optimize.repeat.{" ++ show a ++ "}"-                    opt env a (n + 1 :: Int) nl-                    -}-        --procF (out,env) ((a,_),_) | False <- a `Set.member` reached = do-        --    tick stats (toAtom "Optimize.dead.function")-        --    return (out,env)-        procF (out,env) ((a,l),_) = do-            nl <- opt env a (0::Int) l-            let iname t = toAtom $ "Optimize.simplify.inline." ++ t ++ ".{" ++ fromAtom a  ++ "}"-                inline-                    | a `elem` noInline = Map.empty-                    | a `Set.member` loopBreakers = Map.empty-                    | Hist.find a hist == 1 = Map.singleton a (iname "once",nl)-                    | a `Set.member` indirectFuncs = Map.empty-                    | isSimple (a,nl) = Map.singleton a (iname "simple",nl)-                    | otherwise = Map.empty-            return ((a,nl):out , inline `Map.union` env)--    (nf,_) <- foldM procF ([],mempty) os-    return $ setGrinFunctions nf grin---noInline = [toAtom "fData.IORef.readIORef", toAtom "fData.IORef.writeIORef"]----- TODO have this collect CAF info ignoring updates.--collectUsedFuncs :: Lam -> ([Atom],[Atom])-collectUsedFuncs (as :-> exp) = (snub $ concatMap tagToFunction (Seq.toList iu),sort $ Seq.toList du) where-    (iu,du) =  f exp-    f (e1 :>>= _ :-> e2) = f e1 `mappend` f e2-    f (App a vs _) =  (Seq.fromList (freeVars vs), Seq.singleton a)-    f (Case e alts) =  mconcat ((Seq.fromList (freeVars e) , Seq.empty):[ f e | _ :-> e <- alts])-    f e = (Seq.fromList [ v | v <- freeVars e ],Seq.empty)----- renames all functions to unique names, grin-wide--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 mapGrinFuncsM 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))--mapGrinFuncsM :: Monad m => (Lam -> m Lam) -> Grin -> m Grin-mapGrinFuncsM f grin = liftM (`setGrinFunctions` grin) $ mapM  (\x -> do nb <- f (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin)---
+ src/Grin/Types.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}+module Grin.Types+    ( module Grin.Types+    , module Grin.SimpleCore.Types+    ) where++import CompactString++import Grin.SimpleCore.Types (Lit(..))++import Data.Binary+import Data.DeriveTH+import Control.Monad  (ap)+++-- Invariants:+--   The nodes referred to by the functions are a subset of the nodes in 'grinNodes'.+data Grin+    = Grin { grinNodes     :: [NodeDef]+           , grinCAFs      :: [CAF]+           , grinFunctions :: [FuncDef]+           , grinUnique    :: Int+           }++data CAF+    = CAF { cafName  :: Renamed+          , cafValue :: Value+          }++data FuncDef+    = FuncDef { funcDefName :: Renamed+              , funcDefArgs :: [Renamed]+              , funcDefBody :: Expression+              }++data NodeDef+    = NodeDef { nodeName :: Renamed+              , nodeType :: NodeType+              , nodeArgs :: [Type]+              }++{-+  ConstructorNodes represent data, like: Nil, Cons, Char, etc.+  FunctionNodes represents suspended functions which may be partially applied.+-}+data NodeType+    = ConstructorNode+    | FunctionNode+    deriving (Show,Eq,Ord)++data Type+    = PtrType+    | WordType+    | NodeType+    deriving (Eq)++data Lambda = Renamed :-> Expression+data Alt = Value :> Expression++infixr 1 :->+infixr 1 :>>=+infixr 1 :>>++data Expression+    = Expression :>>= Lambda+    | Expression :>> Expression+    | Application { expFunction :: Renamed+                  , expArgs     :: [Renamed] }+    | Case        { expValue    :: Renamed+                  , expAlts     :: [Alt] }+    | Store       Value+    | Unit        Value++type Variable = CompactString++-- FIXME: Writer manual Eq and Ord instances for Renamed.+data Renamed = Aliased Int CompactString+             | Anonymous Int+             | Builtin CompactString+             | External String+    deriving (Show,Eq,Ord)++isAliased, isBuiltin, isExternal :: Renamed -> Bool++isAliased Aliased{} = True+isAliased _ = False++isBuiltin Builtin{} = True+isBuiltin _ = False++isExternal External{} = True+isExternal _ = False++alias :: Renamed -> Maybe CompactString+alias (Aliased _ name) = Just name+alias _ = Nothing++data Value+    = Node Renamed NodeType Int [Renamed]+    | Vector [Renamed]+    | Lit Lit+    | Variable Renamed+    | Hole Int+    | Empty+    deriving (Show,Eq)+++$(derive makeBinary ''NodeType)+$(derive makeBinary ''Renamed)+$(derive makeBinary ''Value)+$(derive makeBinary ''CAF)+$(derive makeBinary ''FuncDef)+$(derive makeBinary ''NodeDef)+$(derive makeBinary ''Expression)+$(derive makeBinary ''Type)+$(derive makeBinary ''Alt)+$(derive makeBinary ''Lambda)+$(derive makeBinary ''Grin)+
− src/Grin/Unboxing.hs 
@@ -1,120 +0,0 @@-module Grin.Unboxing(unboxReturnValues) where--import Maybe-import Monad-import qualified Data.Map as Map-import qualified Data.Set as Set--import StringTable.Atom-import GenUtil-import Grin.Grin-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 
@@ -1,116 +0,0 @@-module Grin.Val(-    FromVal(..),-    ToVal(..),-    tn_2Tup,-    valToList,-    cChar,-    cWord,-    cInt,-    convertName,-    region_heap,-    region_block-    ) where--import StringTable.Atom-import Char-import Grin.Grin-import Name.VConsts-import Name.Names-import Name.Name-import Cmm.Number--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 in the innermost enclosing region, including implicit regions.-region_block = Item (toAtom "block") 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 
@@ -1,209 +0,0 @@-module Grin.Whiz(whiz, fizz, whizState, normalizeGrin,normalizeGrin', applySubstE, applySubst, whizExps) where--import Control.Monad.Identity-import Control.Monad.State-import Control.Monad.Writer-import Data.Monoid-import qualified Data.Map as Map-import qualified Data.Set as Set--import Grin.Grin-import Grin.Noodle-import Support.CanType--type WhizState = Either (Set.Set Int) Int-type WhizEnv = Map.Map 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 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 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 <- Map.lookup 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 (Map.singleton 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 `Set.member` s = v (n + Set.size s)-                    | otherwise = n-            put (Left $! Set.insert nv s)-            return (V nv)-        Right n -> do-            put $! (Right $! (n + 1))-            return $ V n---
− src/Ho/Binary.hs 
@@ -1,54 +0,0 @@-module Ho.Binary() where---import Control.Monad-import Data.Binary--import Ho.Type---import Name.Binary()---instance Binary HoHeader where-    put (HoHeader aa ab ac ad) = do-	    put aa-	    put ab-	    put ac-	    put ad-    get = do-        aa <- get-        ab <- get-        ac <- get-        ad <- get-        return (HoHeader aa ab ac ad)--instance Binary HoBuild where-    put (HoBuild ae af ag ah ai ak al am) = do-	    put ae-	    put af-	    put ag-	    put ah-	    put ai-	    put ak-	    put al-	    put am-    get = do-    ae <- get-    af <- get-    ag <- get-    ah <- get-    ai <- get-    ak <- get-    al <- get-    am <- get-    return (HoBuild ae af ag ah ai ak al am)---instance Binary HoExp where-    put (HoExp ac ad) = do-	    put ac-	    put ad-    get = do-    ac <- get-    ad <- get-    return (HoExp ac ad)-
− src/Ho/Build.hs 
@@ -1,744 +0,0 @@-module Ho.Build (-    module Ho.Type,-    dumpHoFile,-    compileModules,-    doDependency,-    buildLibrary-    ) where---import Codec.Compression.GZip-import Control.Monad.Identity-import Control.Concurrent-import Data.Binary-import Data.Char-import Data.Monoid-import Data.IORef-import Data.Tree-import Data.List hiding(union)-import Maybe-import Monad-import Text.Printf-import Prelude hiding(print,putStrLn)-import System.IO hiding(print,putStrLn)-import System.Posix.Files-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Text.PrettyPrint.ANSI.Leijen as PPrint--import Data.DeriveTH-import Data.Derive.All-import PackedString(packString)-import CharIO-import DataConstructors-import Directory-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import E.E-import E.Rules-import E.Traverse(emapE)-import E.TypeCheck()-import FrontEnd.Class-import FrontEnd.HsParser-import FrontEnd.Infix-import FrontEnd.ParseMonad-import FrontEnd.Syn.Options-import FrontEnd.Unlit-import FrontEnd.Warning-import FrontEnd.SrcLoc-import RawFiles(prelude_m4)-import Ho.Binary()-import Ho.Library-import Ho.Collected()-import Ho.Type-import FrontEnd.HsSyn-import Options-import Support.CFF-import Util.FilterInput-import Util.Gen hiding(putErrLn,putErr,putErrDie)-import Util.SetLike-import LHCVersion-import Data.GraphViz as GV-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified FlagDump as FD-import qualified FlagOpts as FO-import qualified Util.Graph as G-import qualified Data.Graph.Inductive as GI-import qualified Data.Digest.Pure.MD5 as MD5-import qualified Codec.Binary.UTF8.String as UTF8-import System.FilePath (takeExtension)------- 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 "LHC"------ 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--- RDRT - redirect to another file for systems without symlinks--- DEFS - definitions and exports for modules, all that is needed for name resolution--- TCIN - type checking information--- CORE - compiled core and associated data--- GRIN - compiled grin code--------cff_magic = chunkType "LHC"-cff_rdrt  = chunkType "RDRT"-cff_jhdr  = chunkType "JHDR"-cff_core  = chunkType "CORE"-cff_defs  = chunkType "DEFS"-cff_idep  = chunkType "IDEP"---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---instance DocLike d => PPrint d MD5.MD5Digest where-    pprintPrec _ h = tshow h-instance (DocLike d, PPrint d a) => PPrint d (Maybe a) where-    pprintPrec _ Nothing  = text "Nothing"-    pprintPrec x (Just a) = pprintPrec x a--findFirstFile :: String -> [(FilePath,a)] -> IO (LBS.ByteString,FilePath,a)-findFirstFile err [] = FrontEnd.Warning.err "missing-dep" ("Module not found: " ++ err) >> fail ("Module not found: " ++ err) -- return (error "findFirstFile not found","",undefined)-findFirstFile err ((x,a):xs) = flip catch (\e ->   findFirstFile err xs) $ do-    bs <- LBS.readFile x-    return (bs,x,a)---data ModDone-    = ModNotFound-    | ModLibrary String HoHash-    | Found SourceCode--data SourceCode-    = SourceParsed { sourceHash :: SourceHash, sourceDeps :: [Module]-                   , sourceModule :: HsModule, sourceFP :: FilePath, sourceHoName :: FilePath }-    | SourceRaw    { sourceHash :: SourceHash, sourceDeps :: [Module]-                   , sourceModName :: Module, sourceLBS :: LBS.ByteString, sourceFP :: FilePath, sourceHoName :: FilePath }--data Done = Done {-    knownSourceMap :: Map.Map SourceHash (Module,[Module]),-    hosEncountered :: Map.Map HoHash     (FilePath,HoHeader,Ho),-    modEncountered :: Map.Map Module     ModDone-    }--$(derive makeMonoid ''Done)-$(derive makeUpdate ''Done)--fileOrModule f = case takeExtension f of-                   ".hs"  -> Right f-                   ".lhs" -> Right f-                   _      -> Left $ Module f--{-# NOINLINE doDependency #-}-doDependency :: [String] -> IO ()-doDependency as = do-    done_ref <- newIORef mempty;-    let f (Right f) = fetchSource done_ref [f] Nothing >> return ()-        f (Left m) = resolveDeps done_ref m-    mapM_ (f . fileOrModule) as-    sm <- knownSourceMap `fmap` readIORef done_ref-    mapM_ print $ melems sm--replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix--hoFile :: FilePath -> Maybe Module -> SourceHash -> FilePath-hoFile fp mm sh = case optHoDir options of-    Nothing -> replaceSuffix "ho" fp-    Just hdir -> case mm of-        Nothing -> hdir ++ "/" ++ show sh ++ ".ho"-        Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where-            ft '/' = '.'-            ft x = x--findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath)-findHoFile done_ref fp mm sh = do-    done <- readIORef done_ref-    let honame = hoFile fp mm sh-    if sh `Map.member` knownSourceMap done || optIgnoreHo options then return (False,honame) else do-    onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) -> do-        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 (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,ho))-                return (True,honame)----onErr :: IO a -> IO b -> (b -> IO a) -> IO a-onErr err good cont = catch (good >>= \c -> return (cont c)) (\_ -> return err) >>= id--fetchSource :: IORef Done -> [FilePath] -> Maybe Module -> IO Module-fetchSource _ [] _ = fail "No files to load"-fetchSource done_ref fs mm = do-    let mod = maybe (head fs) show mm-        killMod = case mm of-            Nothing -> fail $ "Could not load file: " ++ show fs-            Just m -> modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m-    onErr killMod (findFirstFile mod [ (f,undefined) | f <- fs]) $ \ (lbs,fn,_) -> do-    let hash = MD5.md5 lbs-    (foundho,mho) <- findHoFile done_ref fn mm hash-    done <- readIORef done_ref-    (mod,m,ds) <- case mlookup hash (knownSourceMap done) of-        Just (m,ds) -> do return (Left lbs,m,ds)-        Nothing -> do-            hmod <- parseHsSource fn lbs-            let m = hsModuleName hmod-                ds = hsModuleRequires hmod-            writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done)-            return (Right hmod,m,ds)-    case mm of-        Just m' | m /= m' -> do-            putErrLn $ "Skipping file" <+> fn <+> "because it's module declaration of" <+> show m <+> "does not equal the expected" <+> show m'-            killMod-        _ -> do-            let sc (Right mod) = SourceParsed hash ds mod fn mho-                sc (Left lbs) = SourceRaw hash ds m lbs fn mho-            modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod)))-            fn' <- shortenPath fn-            mho' <- shortenPath mho-            case foundho of-                False -> putVerboseLn $ printf "%-23s [%s]" (show m) fn'-                True -> putVerboseLn $ printf "%-23s [%s] <%s>" (show m) fn' mho'-            mapM_ (resolveDeps done_ref) ds-            return m--resolveDeps :: IORef Done -> Module -> IO ()-resolveDeps done_ref m = do-    done <- readIORef done_ref-    if isJust $ m `mlookup` modEncountered done then return () else do-    fetchSource done_ref (map fst $ searchPaths (show m)) (Just m)-    return ()--sourceIdent SourceParsed { sourceModule = m } = show $ hsModuleName m-sourceIdent SourceRaw { sourceModName = fp } = show fp--data CompUnit-    = CompHo   (Maybe String)  HoHeader Ho-    | CompSources [SourceCode]-    | CompPhony-    | CompCollected CollectedHo CompUnit--class ProvidesModules a where-    providesModules :: a -> [Module]-    providesModules _ = []--instance ProvidesModules HoHeader where-    providesModules hoh = fsts $ hohDepends hoh--instance ProvidesModules CompUnit where-    providesModules (CompHo _ hoh _)   = providesModules hoh-    providesModules (CompSources ss) = concatMap providesModules ss-    providesModules CompPhony        = []-    providesModules (CompCollected _ cu) = providesModules cu--instance ProvidesModules SourceCode where-    providesModules SourceParsed { sourceModule = mod } = [hsModuleName mod]-    providesModules SourceRaw    { sourceModName = n } = [n]---type CompUnitGraph = [(HoHash,([HoHash],CompUnit))]--showCUnit (hash,(deps,cu)) = printf "%s : %s" (show hash) (show deps)  ++ "\n" ++ f cu where-    f (CompHo (Just s) _ _) = s-    f (CompHo _ _ _) = "ho"-    f (CompSources ss) = show $ map sourceIdent ss----- | 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 CompUnitGraph-toCompUnitGraph done roots = do-    let fs m = maybe (error $ "can't find deps for: " ++ show m) snd (Map.lookup m (knownSourceMap done))-        gr :: G.Graph ((Module, SourceHash), [Module]) Module-        gr = G.newGraph  [ ((m,sourceHash sc),fs (sourceHash sc)) | (m,Found sc) <- Map.toList (modEncountered done)] (fst . fst) snd-        gr' = G.sccGroups gr-        -    -- Note: tred(1) is VERY handy with these graphs!-    when (dump FD.DepGraph) $ do-        let nodes = zip [0..] [(m,sourceHash sc) | (m,Found sc) <- (Map.toList (modEncountered done))]-            nodeMap = Map.fromList [ (sh, n) | (n,(sh,_)) <- nodes ]-            gri :: GI.Gr (Module, SourceHash) ()-            gri = GI.mkGraph nodes [ (n,n2,())-                                     | (n,(_,sh)) <- nodes,-                                       n2 <- concatMap (maybeToList . (`Map.lookup` nodeMap)) (fs sh)-                                   ]-            -            sccMap = Map.fromList [(n, ns) | ns <- (map.map) (fst.fst) gr', n <- ns]--            cluster ln@(_,(m,_)) = case (fromJust $ Map.lookup m sccMap) of-                                     [_] -> N ln-                                     ms  -> C ms (N ln)--            fcluster  _  = [Style Dashed]--            fnode (_,(m,_)) = [Label (show m)]-            fedge _         = []--        writeFile "deps.dot" (show $ clusterGraphToDot gri [GV.Unknown "aspect" "2,10"]-                                                       cluster fcluster fnode fedge)--    let lmods = Map.mapMaybe ( \ x -> case x of ModLibrary _ h -> Just h ; _ -> Nothing) (modEncountered done)-        phomap = Map.fromListWith (++) (concat [  [ (m,[hh]) | (m,_) <- hohDepends hoh ] | (hh,(_,hoh,_)) <- Map.toList (hosEncountered done)])-        sources = Map.fromList [ (m,sourceHash 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 [ (m,r) | ((m,_),_) <- ns ]-    let mods = Map.fromList (concat ms)-    let f m | Just h <- Map.lookup m lmods = hvalid h-        f m = do-            rr <- readIORef $ maybe (error $ "toCompUnitGraph: " ++ show m) id (Map.lookup m mods)-            case rr of-                Right hh -> return hh-                Left ns -> g ns-        g ms@(((m,_),ds):_) = 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.md5 . L.pack $ (concatMap (show . fst) ms ++ show deps')-                writeIORef (fromJust $ Map.lookup m mods) (Right mhash)-                let cunit = CompSources $ map fs amods-                modifyIORef cug_ref ((mhash,(deps',cunit)):)-                return mhash-        pm :: [HoHash] -> IO HoHash -> IO HoHash-        pm [] els = els-        pm (h:hs) els = hvalid h `catch` (\_ -> 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,ho)) -> do-                    fp <- shortenPath fp-                    let stale = map (show . fst) (hohDepends hoh) `intersect` optStale options-                    good <- catch ( mapM_ cdep (hohDepends hoh) >> mapM_ hvalid (hohModDepends hoh) >> return True) (\_ -> return False)-                    if good && null stale then do-                        putVerboseLn $ printf "Fresh: <%s>" fp-                        let lib = case ".ho" `isSuffixOf` fp of-                                    True  -> Nothing-                                    False -> Just fp-                        modifyIORef cug_ref ((h,(hohModDepends hoh,CompHo lib hoh ho)):)-                        modifyIORef hom_ref (Map.insert h (True,af))-                        return h-                     else do-                        putVerboseLn $ if null stale-                            then printf "Stale: <%s>" fp-                            else printf "Stale: <%s> (forced)" fp-                        modifyIORef hom_ref (Map.delete h)-                        fail "don't know this file"-        cdep (_,Nothing)  = return ()-        cdep (mod,Just 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 roots-    readIORef cug_ref--compileModules :: [Either Module String]                             -- ^ Either a module or filename to find-               -> (CollectedHo -> Ho -> IO CollectedHo)              -- ^ Process initial ho loaded from file-               -> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho-               -> IO CollectedHo                                     -- ^ Final accumulated ho--compileModules need ifunc func = do-    (needed,cug) <- loadModules (optHls options) need-    processCug cug >>= mkPhonyCompNode needed >>= compileCompNode ifunc func----- this takes a list of modules or files to load, and produces a compunit graph-loadModules :: [String]                 -- ^ libraries to load-            -> [Either Module String]   -- ^ a list of modules or filenames-            -> IO ([Module],CompUnitGraph)         -- ^ the resulting acyclic graph of compilation units-loadModules libs need = do-    done_ref <- newIORef mempty-    unless (null libs) $ putVerboseLn $ "Loading libraries:" <+> show libs-    forM_ (optHls options) $ \l -> do-        (n',fn) <- findLibrary l-        (hoh,_,ho) <- catch (readHoFile fn) $ \_ ->-            fail $ "Error loading library file: " ++ fn-        putVerboseLn $ printf "Library: %-15s <%s>" n' fn-        modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (n',hoh,ho))-        modifyIORef done_ref (modEncountered_u $ Map.union (Map.fromList [ (m,ModLibrary n' (hohHash hoh)) | m <- providesModules hoh]))-    ms1 <- forM (rights need) $ \fn -> do-        fetchSource done_ref [fn] Nothing-    forM_ (lefts need) $ resolveDeps done_ref-    processIOErrors-    done <- readIORef done_ref-    let needed = (ms1 ++ lefts need)-    cug <- toCompUnitGraph done needed-    return (needed,cug)---data CompNode = CompNode HoHash [CompNode] (IORef CompUnit)--processCug :: CompUnitGraph -> IO [CompNode]-processCug cug = 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 cu-            return $ (h,CompNode h (map lup ds) cur)-    xs <- mapM f cug-    return $ snds xs--mkPhonyCompNode :: [Module] -> [CompNode] -> IO CompNode-mkPhonyCompNode need cs = do-    xs <- forM cs $ \cn@(CompNode _ _ cu) -> readIORef cu >>= \u -> return $ if null $ providesModules u `intersect` need then [] else [cn]-    let hash = MD5.md5 . L.pack $ show [ h | CompNode h _ _ <- concat xs ]-    CompNode hash (concat xs) `fmap` newIORef CompPhony--compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo)              -- ^ Process initial ho loaded from file-                -> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho-                -> CompNode-                -> IO CollectedHo-compileCompNode ifunc func cn = do ns <- countNodes cn-                                   cur <- newMVar (1::Int)-                                   f (Set.size ns) cur cn where-    countNodes (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of-        CompCollected _ _ -> return Set.empty-        CompPhony         -> mconcat `fmap` mapM countNodes deps-        CompHo _ hoh _    -> do ds <- mconcat `fmap` mapM countNodes deps-                                return $ ds `Set.union` Set.fromList (map (show.fst) (hohDepends hoh))-        CompSources sc    -> do ds <- mconcat `fmap` mapM countNodes deps-                                return $ ds `Set.union` Set.fromList (map sourceIdent sc)-    tickProgress cur-        = modifyMVar cur $ \val -> return (val+1,val)-    showProgress maxModules cur ms-        = forM_ ms $ \modName ->-          do curModule <- tickProgress cur-             let l = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int-             printf "[%*d of %*d] %s\n" l curModule l maxModules (show $ hsModuleName modName)-    f n cur (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of-        CompCollected ch _ -> return ch-        CompPhony -> do-            xs <- mconcat `fmap` mapM (f n cur) deps-            writeIORef ref (CompCollected xs CompPhony)-            return xs-        CompHo _ hoh ho -> do-            cho <- mconcat `fmap` mapM (f n cur) deps-            forM_ (hohDepends hoh) $ \_ -> tickProgress cur-            cho <- ifunc cho ho-            writeIORef ref (CompCollected cho cn)-            return cho-        CompSources sc -> do-            let hdep = [ h | CompNode h _ _ <- deps]-            cho <- mconcat `fmap` mapM (f n cur) deps-            modules <- forM sc $ \x -> case x of-                SourceParsed { sourceHash = h,sourceModule = mod } -> return (h,mod)-                SourceRaw { sourceHash = h,sourceLBS = lbs, sourceFP = fp } -> do-                    mod <- parseHsSource fp lbs-                    return (h,mod)-            showProgress n cur (snds modules)-            (cho',newHo) <- func cho (snds modules)-            let hoh = HoHeader {-                                 hohDepends    = [ (hsModuleName mod,Just h) | (h,mod) <- modules],-                                 hohModDepends = hdep,-                                 hohHash       = hh,-                                 hohMetaInfo   = []-                               }-                idep = HoIDeps $ Map.fromList [ (h,(hsModuleName mod,hsModuleRequires mod)) | (h,mod) <- modules]--            recordHoFile newHo idep (map sourceHoName sc) hoh-            writeIORef ref (CompCollected cho' (CompHo Nothing hoh newHo))-            return cho'---findModule :: [Either Module String]                                -- ^ Either a module or filename to find-              -> (CollectedHo -> Ho -> IO CollectedHo)              -- ^ Process initial ho loaded from file-              -> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho-              -> IO (CollectedHo,[(Module,MD5.MD5Digest)],Ho)            -- ^ (Final accumulated ho,just the ho read to satisfy this command)-findModule need ifunc func  = do-    (needed,cug) <- loadModules (optHls options) need-    cnodes <- processCug cug-    rnode <- mkPhonyCompNode needed cnodes-    cho <- compileCompNode ifunc func rnode-    return (cho,undefined,undefined)---- Read in a Ho file.--readHoFile :: FilePath -> IO (HoHeader,HoIDeps,Ho)-readHoFile fn = do-    bs <- BS.readFile 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 $ L.fromChunks [x]-    return (fc cff_jhdr,fc cff_idep,mempty { hoExp = 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-        wdump FD.Progress $ do-            fs' <- mapM shortenPath fs-            putErrLn $ "Skipping Writing Ho Files: " ++ show fs'-      else do-    let removeLink' fn = catch  (removeLink 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-            wdump FD.Progress $ do-                fn_ <- shortenPath fn-                fn_' <- shortenPath fn'-                when (optNoWriteHo options) $ putErr "Skipping "-                putErrLn $ "Linking haskell object file:" <+> fn_' <+> "to" <+> fn_-            if optNoWriteHo options then return () else do-            let tfn = fn' ++ ".tmp"-            removeLink' tfn-            createLink fn tfn-            rename tfn fn'-        f fn = do-            wdump FD.Progress $ 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"-            let theho =  mapHoBodies eraseE ho-                cfflbs = mkCFFfile cff_magic [-                    (cff_jhdr, compress $ encode header),-                    (cff_idep, compress $ encode idep),-                    (cff_defs, compress $ encode $ hoExp theho),-                    (cff_core, compress $ encode $ hoBuild theho)]-            LBS.writeFile tfn cfflbs-            rename tfn fn-    g fs----hsModuleRequires x = Module "Lhc.Prim":ans where-    noPrelude =   or $ not (optPrelude options):[ opt == c | opt <- hsModuleOptions x, c <- ["-N","--noprelude"]]-    ans = snub $ (if noPrelude then id else  (Module "Prelude":)) [  hsImportDeclModule y | y <- hsModuleImports x]--searchPaths :: String -> [(String,String)]-searchPaths 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 options, n <- f m, suf <- [".hs",".lhs"], let root = i ++ "/" ++ n]---m4Prelude :: IO FilePath-m4Prelude = writeFile "/tmp/lhc_prelude.m4" prelude_m4 >> return "/tmp/lhc_prelude.m4"--langmap = [-    "m4" ==> "m4",-    "cpp" ==> "cpp",-    "foreignfunctioninterface" ==> "ffi",-    "noimplicitprelude" ==> "--noprelude",-    "unboxedtuples" ==> "unboxed-tuples"-    ] where x ==> y = (x,if head y == '-' then y else "-f" ++ y)---parseHsSource :: String -> LBS.ByteString -> IO HsModule-parseHsSource fn lbs = do-    let txt = UTF8.decode $ LBS.unpack lbs-    let f s = opt where-            Just opt = fileOptions opts `mplus` Just options-            popts = parseOptions $ if "shl." `isPrefixOf` reverse fn  then unlit fn s else s-            opts' = concat [ words as | (x,as) <- popts, x `elem` ["OPTIONS","LHC_OPTIONS","OPTIONS_LHC"]]-            opts = opts' ++ [ "--noprelude" | ("NOPRELUDE",_) <- popts] ++ langs-            langs = catMaybes $ map (flip lookup langmap) $ concat [ words (map (\c -> if c == ',' then ' ' else toLower c) as) | ("LANGUAGE",as) <- popts ]-    let fopts s = s `member` optFOptsSet initialOpts-        initialOpts = f (take 4096 txt)-        incFlags = [ "-I" ++ d | d <- optIncdirs options ++ optIncs initialOpts]-        defFlags = ("-D__LHC__=" ++ version):[ "-D" ++ d | d <- optDefs initialOpts]--    s <- 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 txt-    let s' = if "shl." `isPrefixOf` reverse fn  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'-    case runParserWithMode (parseModeOptions $ f s) { parseFilename = fn } parse  s'  of-                      ParseOk ws e -> processErrors ws >> return e-                      ParseFailed sl err -> putErrDie $ show sl ++ ": " ++ err---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 -> [HsModule] -> IO (CollectedHo,Ho))-             -> FilePath-             -> IO ()-buildLibrary ifunc func = ans where-    ans fp = do-        (desc,name,hmods,emods) <- parse fp-        let allmods  = sort (emods ++ hmods)--        (needed,cug) <- loadModules (optHls options) (map Left allmods)-        rnode@(CompNode lhash _ _) <- processCug cug >>= mkPhonyCompNode needed-        compileCompNode ifunc func rnode-        (prvds,ho,ldeps) <- let-            f (CompNode hs cd ref) = do-                deps <- mconcat `fmap` mapM f cd-                d <- readIORef ref >>= hunit hs-                return $ d `mappend` deps-            hunit hs x = case x of-                    CompHo (Just s) _ _ -> return (mempty,mempty,Map.singleton hs s)-                    CompHo Nothing hoh ho -> return (Set.fromList $ providesModules hoh,Map.singleton hs ho,mempty)-                    CompCollected _ u -> hunit hs u-                    CompPhony -> return mempty-          in f rnode--        --(cho,libDeps,ho) <- findModule (map Left (emods ++ hmods)) ifunc func-        let unknownMods = Set.toList $ Set.filter (`notElem` allmods) prvds-        mapM_ ((putStrLn . ("*** Module included in library that is not in export list: " ++)) . show) unknownMods-        let outName = case optOutName options of-                "hs.out" -> name ++ ".hl"-                fn -> fn-        let pdesc = [(n, packString v) | (n,v) <- ("lhc-hl-filename",outName):("lhc-description-file",fp):("lhc-compiled-by",versionString):desc, n /= "exposed-modules" ]-        let hoh =  HoHeader {-                hohHash = lhash,-                hohDepends = [ (m,Nothing) | m <- Set.toList prvds ],-                hohModDepends = Map.keys ldeps,-                hohMetaInfo = pdesc-                }-        recordHoFile (mconcat $ Map.elems ho) (HoIDeps Map.empty) [outName] hoh--    -- parse library description file-    parse fp = do-        putVerboseLn $ "Creating library from description file: " ++ show fp-        desc <- readDescFile fp-        when verbose2 $ mapM_ print desc-        let field x = lookup x desc-            jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ field x-            mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ field x-        name <- jfield "name"-        vers <- jfield "version"-        let hmods = map Module $ snub $ mfield "hidden-modules"-            emods = map Module $ snub $ mfield "exposed-modules"-        return (desc,name ++ "-" ++ vers,hmods,emods)------------------------------------------ dumping contents of a ho file----------------------------------------instance DocLike d => PPrint d SrcLoc where-    pprint sl = tshow sl--vindent xs = vcat (map ("    " ++) xs)--{-# NOINLINE dumpHoFile #-}-dumpHoFile :: String -> IO ()-dumpHoFile fn = do-    (hoh,idep,ho) <- readHoFile fn-    let hoB = hoBuild ho-        hoE = hoExp ho-    putStrLn fn-    putStrLn $ "HoHash:" <+> pprint (hohHash hoh)-    when (not $ Map.null (hoIDeps idep)) $ putStrLn $ "IDeps:\n" <>  vindent (map pprint . Map.toList $ hoIDeps idep)-    when (not $ Prelude.null (hohDepends hoh)) $ putStrLn $ "Dependencies:\n" <>  vindent (map pprint . sortUnder fst $ hohDepends hoh)-    when (not $ Prelude.null (hohModDepends hoh)) $ putStrLn $ "ModDependencies:\n" <>  vindent (map pprint $ hohModDepends hoh)-    when (not $ Prelude.null (hohMetaInfo hoh)) $ putStrLn $ "MetaInfo:\n" <> vindent (sort [text (' ':' ':k) <> char ':' <+> show v | (k,v) <- hohMetaInfo hoh])-    putStrLn $ "Modules contained:" <+> tshow (mkeys $ hoExports hoE)-    putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE)-    putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoB)-    putStrLn $ "hoFixities:" <+> tshow (size $  hoFixities hoB)-    putStrLn $ "hoKinds:" <+> tshow (size $  hoKinds hoB)-    putStrLn $ "hoClassHierarchy:" <+> tshow (size $  hoClassHierarchy hoB)-    putStrLn $ "hoTypeSynonyms:" <+> tshow (size $  hoTypeSynonyms hoB)-    putStrLn $ "hoDataTable:" <+> tshow (size $  hoDataTable hoB)-    putStrLn $ "hoEs:" <+> tshow (size $  hoEs hoB)-    putStrLn $ "hoRules:" <+> tshow (size $  hoRules hoB)-    wdump FD.Exports $ do-        putStrLn "---- exports information ----";-        CharIO.putStrLn $  (pprint $ hoExports hoE :: String)-    wdump FD.Defs $ do-        putStrLn "---- defs information ----";-        CharIO.putStrLn $  (pprint $ hoDefs hoE :: String)-    when (dump FD.Kind) $ do-        putStrLn "---- kind information ----";-        CharIO.putStrLn $  (pprint $ hoKinds hoB :: String)-    when (dump FD.ClassSummary) $ do-        putStrLn "---- class summary ---- "-        printClassSummary (hoClassHierarchy hoB)-    when (dump FD.Class) $-         do {putStrLn "---- class hierarchy ---- ";-             printClassHierarchy (hoClassHierarchy 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 CharIO.putStr (showDataTable (hoDataTable hoB))-         putChar '\n'-    wdump FD.Types $ do-        putStrLn " ---- the types of identifiers ---- "-        putStrLn $ show (pprint (hoAssumps hoB) :: PPrint.Doc)-    wdump FD.Core $ do-        putStrLn " ---- lambdacube  ---- "-        mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB)-    where-    printCheckName'' :: DataTable -> TVr -> E -> IO ()-    printCheckName'' _dataTable tvr e = do-        when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr)-        putStrLn (show (hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr)) :: PPrint.Doc))-        putStrLn (show (hang 4 (pprint tvr <+> equals <+> pprint e) :: PPrint.Doc))
− src/Ho/Collected.hs 
@@ -1,81 +0,0 @@-module Ho.Collected(-    CollectedHo(..),-    choDataTable,-    choClassHierarchy,-    choTypeSynonyms,-    choFixities,-    choAssumps,-    choRules,-    choEs,-    choHo-    )where--import Data.Monoid-import Control.Monad.Identity-import Data.List--import Util.SetLike-import Ho.Type-import E.E-import DataConstructors-import Info.Types-import E.Annotate-import qualified Info.Info as Info-import qualified Data.Map as Map---choDataTable = hoDataTable . hoBuild . choHo-choClassHierarchy = hoClassHierarchy . hoBuild . choHo-choTypeSynonyms = hoTypeSynonyms . hoBuild . choHo-choFixities = hoFixities . hoBuild . choHo-choAssumps = hoAssumps . hoBuild . choHo-choRules = hoRules . hoBuild . choHo-choEs cho = [ (combHead c,combBody c) | c <- melems $  choCombinators cho]--instance Monoid CollectedHo where-    mempty = CollectedHo {-        choExternalNames = mempty,-        choOrphanRules = mempty,-        choHoMap = Map.singleton "Prim@" pho,-        choCombinators = mempty,-        choVarMap = mempty-        } where pho = mempty { hoBuild = mempty { hoDataTable = dataTablePrims } }-    a `mappend` b = CollectedHo {-        choExternalNames = choExternalNames a `mappend` choExternalNames b,-        choVarMap = choVarMap a `mergeChoVarMaps` choVarMap b,-        choOrphanRules = choOrphanRules a `mappend` choOrphanRules b,-        choCombinators = choCombinators a `mergeChoCombinators` choCombinators b,-        choHoMap = Map.union (choHoMap a) (choHoMap b)-        }--choHo cho = hoBuild_u (hoEs_u f) . mconcat . Map.elems $ choHoMap cho where-    f ds = runIdentity $ annotateDs mmap  (\_ -> return) (\_ -> return) (\_ -> return) (map g ds) where-        mmap = mfilterWithKey (\k _ -> (k `notElem` (map (tvrIdent . fst) ds))) (choVarMap cho)-    g (t,e) = case mlookup (tvrIdent t) (choVarMap cho) of-        Just (Just (EVar t')) -> (t',e)-        _ -> (t,e)- --   ae = runIdentity . annotate (choVarMap cho) (\_ -> return) (\_ -> return) (\_ -> return)---- this will have to merge rules and properties.-mergeChoVarMaps :: IdMap (Maybe E) -> IdMap (Maybe E) -> IdMap (Maybe E)-mergeChoVarMaps x y = munionWith f x y where-    f (Just (EVar x)) (Just (EVar y)) = Just . EVar $ merge x y-    f x y = error "mergeChoVarMaps: bad merge."-    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---- this will have to merge rules and properties.-mergeChoCombinators :: IdMap Comb -> IdMap Comb -> IdMap Comb-mergeChoCombinators x y = munionWith 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 
@@ -1,93 +0,0 @@-module Ho.Library(-    readDescFile,-    findLibrary,-    libraryList-    ) where--import Char-import Control.Monad-import System.IO-import System.Directory-import qualified Data.Map as Map--import GenUtil-import Options-import qualified CharIO-import qualified FlagDump as FD--type LibraryName = String-------------------------------------------- parse description file (.cabal file)------------------------------------------readDescFile :: FilePath -> IO [(String,String)]-readDescFile fp = do-    wdump FD.Progress $ putErrLn $ "Reading: " ++ show fp-    fc <- CharIO.readFile fp-    case parseLibraryDescription fc of-        Left err -> fail $ "Error reading library description file: " ++ show fp ++ " " ++ err-        Right ps -> return ps--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 [] = []-------------------------------------- finding and listing libraries-----------------------------------type LibraryMap = Map.Map LibraryName FilePath---findLibrary ::  LibraryName -> IO (LibraryName,FilePath)-findLibrary pn = do-    lm <- getLibraryMap (optHlPath options)-    case Map.lookup pn lm of-        Just x  -> return (pn,x)-        Nothing -> case range (pn++"-") (pn++"-"++repeat maxBound) lm of-                 [] -> fail ("LibraryMap: Library "++pn++" not found!")-                 xs -> return $ last xs----libraryList :: IO [(LibraryName,FilePath)]-libraryList = Map.toList `fmap` getLibraryMap (optHlPath options)------ range queries for Data.Map--range :: Ord k => k -> k -> Map.Map k v -> [(k,v)]-range low high = Map.toList . fst . Map.split high . snd . Map.split low--------getLibraryMap :: [FilePath] -> IO LibraryMap-getLibraryMap fps = fmap Map.unions $ mapM getPM fps where-    getPM fp = flip catch (\_ -> return Map.empty) $ do-        raw <- getDirectoryContents fp-        return $ Map.fromList $ flip concatMap raw $ \e ->-            case reverse e of-              ('l':'h':'.':r) -> [(reverse r,fp++"/"++e)]-              _               -> []-
− src/Ho/Type.hs 
@@ -1,119 +0,0 @@-module Ho.Type where--import Data.Monoid-import qualified Data.Map as Map--import Data.DeriveTH-import Data.Derive.All-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.SrcLoc(SrcLoc)-import FrontEnd.Tc.Type(Type())-import FrontEnd.HsSyn(Module)-import Name.Id-import Name.Name(Name)-import FrontEnd.TypeSynonyms(TypeSynonyms)-import PackedString-import Data.Binary-import qualified Data.Digest.Pure.MD5 as MD5-import Control.Monad--type SourceHash = MD5.MD5Digest-type HoHash     = MD5.MD5Digest---- the collected information that is passed around-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,-    choCombinators  :: IdMap Comb,-    -- this is a map of ids to their full TVrs with all rules and whatnot attached.-    -- 'choVarMap' will never contain any Nothing elements. The Maybe is only there-    -- because the map is handed over to 'E.Annotate.annotateDs'.-    choVarMap :: IdMap (Maybe E),-    -- these are rules that may need to be retroactively applied to other modules-    choOrphanRules :: Rules,-    -- the hos-    choHoMap :: Map.Map String Ho-    }----- this is the immutable information about modules that depnends only on their contents--- it can be trusted even if the ho file itself is out of date.-newtype HoIDeps = HoIDeps {-    hoIDeps :: Map.Map SourceHash (Module,[Module])-    }--data HoHeader = HoHeader {-    -- * my sha1 id-    hohHash       :: HoHash,-    -- * Haskell Source files depended on-    hohDepends    :: [(Module,Maybe SourceHash)],-    -- * Other objects depended on to be considered up to date.-    hohModDepends :: [HoHash],-    -- * metainformation, filled for hl-files, empty for normal objects.-    hohMetaInfo   :: [(String,PackedString)]-    }---- data only needed for name resolution-data HoExp = HoExp {-    hoExports :: Map.Map Module [Name],-    hoDefs :: Map.Map Name (SrcLoc,[Name])-    }---data HoBuild = HoBuild {-    hoAssumps :: Map.Map Name Type,        -- used for typechecking-    hoFixities :: FixityMap,-    hoKinds :: KindEnv,                      -- used for typechecking-    hoClassHierarchy :: ClassHierarchy,-    hoTypeSynonyms :: TypeSynonyms,-    -- Filled in by E generation-    hoDataTable :: DataTable,-    hoEs :: [(TVr,E)],-    hoRules :: Rules-    }--data Ho = Ho {-    hoExp :: HoExp,-    hoBuild :: HoBuild-    }-$(derive makeUpdate ''Ho)-$(derive makeUpdate ''CollectedHo)-$(derive makeBinary ''HoIDeps)-$(derive makeUpdate ''HoBuild)--instance Monoid Ho where-    mempty = Ho mempty mempty-    mappend a b = Ho {-        hoExp = hoExp a `mappend` hoExp b,-        hoBuild = hoBuild a `mappend` hoBuild b-    }--instance Monoid HoExp where-    mempty = HoExp mempty mempty-    mappend a b = HoExp {-        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-    }---
− src/Info/Binary.hs 
@@ -1,84 +0,0 @@-module Info.Binary(putInfo, Info.Binary.getInfo) where--import Data.Dynamic-import qualified Data.Map as Map--import StringTable.Atom(HasHash(..))-import Data.Binary-import C.FFI(FfiExport)-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--createTyp :: Typeable a => a -> Word32-createTyp x = hash32 $ (show (typeOf x))-newEntry x = Entry { entryThing = toDyn x, entryString = show x, entryType = typeOf x }--cb x = (createTyp x, Binable x)--binTable :: Map.Map Word32 Binable-binTable = Map.fromList [-    cb (u :: Properties),-    cb (u :: E.CPR.Val),-    cb (u :: FfiExport),-    cb (u :: E.Demand.DemandSignature)-    ]---putDyn :: (Word32,Dynamic,Binable) -> Put-putDyn (ps,d,Binable (_::a)) = do-    put ps-    put (fromDyn d (error (show d)) :: a)---- = case Map.lookup (packString (show d)) of---    Just (Binable (x::a)) -> put_ h (case fromDynamic d of Just x -> x :: a)---    Nothing -> return ()---getDyn = do-    (ps::Word32) <- 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 (EnumBitSet props)) = put (fromIntegral $ BS.toWord props :: Word32)-    get = (get :: Get Word32) >>= return . Properties . EnumBitSet . 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-            let ps = hash32 $ (show $ entryType d)-            case Map.lookup ps binTable of-              Just 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  [ x | x <- xs])---
− src/Info/Binary.hs-boot 
@@ -1,7 +0,0 @@-module Info.Binary where--import Info.Info-import Data.Binary--putInfo :: Info.Info.Info -> Put-getInfo :: Get Info.Info.Info
− src/Info/Info.hs 
@@ -1,165 +0,0 @@-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.Generics-import Data.Monoid-import Monad-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)---- FIXME: Why don't we derive Data?-instance Data Info where-    toConstr = undefined-    dataTypeOf = undefined-    gunfold = 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 
@@ -1,63 +0,0 @@-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 
@@ -1,64 +0,0 @@--- | 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 Info.Properties-import Data.Dynamic-import Data.Monoid--import Util.HasSize-import Util.SetLike-import Util.BitSet-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,HasSize,Monoid,SetLike,BuildSet Property,ModifySet Property,IsEmpty)----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/LHCVersion.hs 
@@ -1,19 +0,0 @@--- | Defines some info about the compiler-module LHCVersion where-import Data.Version-import Data.List-import System.Info-import qualified Paths_lhc as P--package        = "lhc"-tag            = "scio"-version        = showVersion P.version-shortVersion   = concat $ intersperse "." $ map show $ take 3 $ versionBranch P.version---- | Simple version string-{-# NOINLINE versionSimple #-}-versionSimple = unwords [package, version, "("++tag++")"]---- | Full version string containing OS/compiler info-{-# NOINLINE versionString #-}-versionString = concat [versionSimple, " compiled by ",compilerName,"-",showVersion compilerVersion," on a ",arch," running ",os]
+ src/LhcMain.hs view
@@ -0,0 +1,138 @@+module LhcMain (tryMain) where++import System.Directory+import System.FilePath+import System.Environment+import qualified Data.ByteString.Lazy.Char8 as L+import System.IO+import System.Exit+import qualified Data.Map as Map+import Data.Binary+import Data.Maybe+import Control.Monad++import CompactString+import qualified Language.Core as Core+import Grin.SimpleCore+import Grin.FromCore+import Grin.Pretty+import qualified Grin.SimpleCore.DeadCode as Simple+import qualified Grin.Eval.Compile as Compile+import qualified Grin.Optimize.Simple as Simple+import qualified Grin.HtmlAnnotate as Html++--import Grin.Rename+import qualified Grin.HPT as HPT+import qualified Grin.Lowering.Apply as Apply++-- TODO: We need proper command line parsing.+tryMain :: IO ()+tryMain = do args <- getArgs+             case args of+               ("install":files)      -> mapM_ installCoreFile files >> exitWith ExitSuccess+               ("build":file:args)    -> build Build file args >> exitWith ExitSuccess+               ("eval":file:args)     -> build Eval file args >> exitWith ExitSuccess+               ("compile":file:args)  -> build Compile file args >> exitWith ExitSuccess+               ("execute":file:args)  -> execute file args >> exitWith ExitSuccess+               _ -> return ()+++installCoreFile :: FilePath -> IO ()+installCoreFile path+    = do inp <- L.readFile path+         hPutStr stderr $ "Parsing " ++ path ++ "..."+         hFlush stdout+         case Core.parseModule "file" inp of+           Left errs -> hPutStrLn stderr "errors: " >> print errs+           Right mod  -> do hPutStrLn stderr " done"+                            dataDir <- getAppUserDataDirectory "lhc"+                            let smod = coreToSimpleCore mod+                            createDirectoryIfMissing False (dataDir </> modulePackage smod)+                            encodeFile (dataDir </> modulePackage smod </> moduleName smod) smod++data Action = Build | Eval | Compile++build :: Action -> FilePath -> [String] -> IO ()+build action file args+    = do mod <- parseCore file+         libs <- loadAllLibraries+         let primModule = SimpleModule { modulePackage = "ghczmprim"+                                       , moduleName    = "GHCziPrim"+                                       , moduleTypes   = [SimpleType (fromString "ghc-prim:GHC.Prim.(# #)") 1+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,#)") 2+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,#)") 3+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,#)") 4+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,#)") 5+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,#)") 6+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,#)") 7+                                                         ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,#)") 8]+                                       , moduleDefs    = [] }+         let allModules = Map.insert (modulePackage primModule, moduleName primModule) primModule $+                          Map.insert (modulePackage mod, moduleName mod) mod libs+             (tdefs, defs) = Simple.removeDeadCode [("main","Main")]  ["main::Main.main"] allModules+             grin = coreToGrin tdefs defs+             opt = iterate Simple.optimize grin !! 2+             applyLowered = Apply.lower opt+             (iterations, hpt) = HPT.analyze applyLowered+             evalLowered = HPT.lower hpt applyLowered+             opt' = iterate Simple.optimize evalLowered !! 2+             out = opt'+         case action of+           Build -> print (ppGrin out)+           Eval  -> Compile.runGrin out "main::Main.main" args >> return ()+           Compile -> do let target = replaceExtension file "lhc"+                         outputGrin target "_raw" grin+                         outputGrin target "_simple" opt+                         outputGrin target "_apply" applyLowered+                         outputGrin target "_eval" evalLowered+                         --outputAnnotation target "_eval.html" Map.empty evalLowered+                         outputGrin target "" out+                         --outputAnnotation target ".html" Map.empty out++                         putStrLn $ "Fixpoint found in " ++ show iterations ++ " iterations."++                         lhc <- findExecutable "lhc"+                         L.writeFile target $ L.unlines [ L.pack $ "#!" ++ fromMaybe "/usr/bin/env lhc" lhc ++ " execute"+                                                        , encode out ]+                         perm <- getPermissions target+                         setPermissions target perm{executable = True}++outputGrin file variant grin+    = do let outputFile = replaceExtension file ("grin"++variant)+         writeFile outputFile (show $ ppGrin grin)+         return ()++outputAnnotation file variant annotation grin+    = do let outputFile = replaceExtension file ("grin"++variant)+         writeFile outputFile (Html.annotate annotation grin)++execute :: FilePath -> [String] -> IO ()+execute path args+    = do inp <- L.readFile path+         let grin = decode (dropHashes inp)+         --eval grin "main::Main.main" args+         Compile.runGrin grin "main::Main.main" args+         return ()+    where dropHashes inp | L.pack "#" `L.isPrefixOf` inp = L.unlines (drop 1 (L.lines inp))+                         | otherwise = inp+++loadAllLibraries :: IO (Map.Map ModuleIdent SimpleModule)+loadAllLibraries+    = do dataDir <- getAppUserDataDirectory "lhc"+         packages <- getDirectoryContents dataDir+         smods <- forM (filter (`notElem` [".",".."]) packages) $ \package ->+                  do modules <- getDirectoryContents (dataDir </> package)+                     forM (filter (`notElem` [".",".."]) modules) $ \mod ->+                       do smod <- decodeFile (dataDir </> package </> mod)+                          return ((package,mod),smod)+         return $ Map.fromList [ (ident, mod) | (ident,mod) <- concat smods ]+++parseCore :: FilePath -> IO SimpleModule+parseCore path+    = do inp <- L.readFile path+         case Core.parseModule path inp of+           Left errs -> error (show errs)+           Right mod -> do --putStrLn $ "parsing done: " ++ path+                           return (coreToSimpleCore mod)
− src/Main.hs 
@@ -1,996 +0,0 @@-{-# LANGUAGE CPP #-}-module Main(main) where--import Control.Exception-import qualified Prelude as P (catch)-import Control.Monad.Identity-import Control.Monad.Writer-import Control.Monad.State-import System.IO(hFlush,stderr,stdout)-import Prelude hiding(putStrLn, putStr,print)-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified List(group,union)-import qualified System-import qualified System.Exit as Exit-import Util.Util-import StringTable.Atom-import C.Arch-import CharIO-import DataConstructors-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import E.Annotate(annotateDs,annotateCombs,annotateProgram)-import E.Diff-import E.E-import E.Eta-import E.FreeVars-import E.FromHs-import E.Inline-import E.LambdaLift-import E.LetFloat-import E.Program-import E.Rules-import E.Show hiding(render)-import E.Subst(subst)-import E.Traverse-import E.TypeAnalysis-import E.TypeCheck-import E.WorkerWrapper-import FrontEnd.Class-import FrontEnd.FrontEnd-import FrontEnd.KindInfer(getConstructorKinds)-import GenUtil hiding(replicateM,putErrLn,putErr,putErrDie)-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.Show-import Ho.Build-import Ho.Library-import Ho.Collected-import FrontEnd.HsSyn-import Info.Types-import Name.Id-import Name.Name-import Name.Names-import Name.VConsts-import Options-import Support.FreeVars-import Support.CanType(getType)-import Support.Transform-import Util.Graph-import Util.SetLike as S-import LHCVersion-import qualified C.FromGrin2 as FG2-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 Grin.Simplify-import qualified Grin.SSimplify-import qualified Info.Info as Info-import qualified Stats-import qualified System.IO as IO-import System.FilePath (takeExtension)-import System.Directory (removeFile)--#if BASE4-runMain action = Control.Exception.catches (action >> return ())-                   [ Handler $ \ (e::Exit.ExitCode) -> throw e-                   , Handler $ \ (e::SomeException) -> putErrDie $ show e ]-#else-runMain action = Control.Exception.catch (action >> return ()) $ \e ->-                   case e of-                     ExitException c -> throw (ExitException c)-                     other -> putErrDie $ show e-#endif--progress str = wdump FD.Progress $  (putErrLn str) >> hFlush stderr-progressM c  = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr---collectPassStats = verbose--bracketHtml action = do-    (argstring,_) <- getArgString-    wdump FD.Html $ putStrLn $ "<html><head><title>" ++ argstring ++ "</title><meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"></head><body style=\"background: black; color: lightgrey\"><pre>"-    action `finally` (wdump FD.Html $ putStrLn "</pre></body></html>")--catom action = action `finally` dumpToFile--main = runMain $ do-    o <- processOptions-    progressM $ do-        (argstring,_) <- getArgString-        return (argstring ++ "\n" ++ versionSimple)-    case optMode o of-        BuildHl hl    -> makeLibrary processInitialHo processDecls hl-        ListLibraries -> do-            when (optVerbose options > 0) $ do-                putStrLn "Search path:"-                mapM_ putStrLn (optHlPath options)-                putStrLn "Libraries found:"-            ll <- libraryList-            sequence_ [ putStrLn name | (name,_) <- ll ]-        ShowHo ho     -> dumpHoFile ho-        Version       -> putStrLn versionString-        DependencyTree -> doDependency (optArgs o)-        _             -> processFiles  (optArgs o)---processFiles [] | Nothing <- optMainFunc options = do-                               putErrDie "lhc: no input files"-                               processFilesModules [Left (Module "Prelude")]-processFiles [] | Just (b,m) <- optMainFunc options = do-                                  m <- return $ parseName Val m-                                  m <- getModule m-                                  processFilesModules [Left m]-processFiles cs = do processFilesModules (map fileOrModule cs)--processFilesModules fs = do-    compileModEnv =<< parseFiles fs processInitialHo processDecls--fileOrModule f = case takeExtension f of-                   ".hs"  -> Right f-                   ".lhs" -> Right f-                   _      -> Left $ Module f-----barendregtProg prog = transformProgram transBarendregt prog-barendregtProg prog = return prog--transBarendregt = transformParms {-        transformCategory = "Barendregt",-        transformIterate = DontIterate,-        transformDumpProgress = corePass,-        transformOperation =  evaluate . barendregtProgram-        } where-    barendregtProgram prog | null $ progCombinators prog = prog-    barendregtProgram prog = programSetDs ds' prog where-        (ELetRec ds' Unknown,_) = renameE mempty mempty (ELetRec (programDs prog) Unknown)---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 = do-    let Rules rm = hoRules $ hoBuild aho-        newTVrs = fsts $ hoEs (hoBuild aho)-        (_,orphans) = mpartitionWithKey (\k _ -> k `elem` map tvrIdent newTVrs) rm--    let fakeEntry = emptyComb { combRules = map ruleUpdate . concat $ melems orphans }-        combs =  fakeEntry:[combRules_s (map ruleUpdate $ mfindWithDefault [] (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 $ mfindWithDefault emptyComb emptyId choCombinators'-        reRule :: Comb -> Comb-        reRule comb = combRules_u f comb where-            f rs = List.union  rs [ x | x <- nrules, ruleHead x == combHead comb]--    let finalVarMap = mappend (fromList [(tvrIdent tvr,Just $ EVar tvr) | tvr <- map combHead $ melems choCombs ]) (choVarMap accumho)-        choCombs = mfilterWithKey (\k _ -> not (isEmptyId k)) choCombinators'-        (mod:_) = Map.keys $ hoExports $ hoExp aho-    return $ mempty {-        choVarMap = finalVarMap,-        choExternalNames = choExternalNames accumho `mappend` (fromList . map tvrIdent $ newTVrs),-        choCombinators = choCombs `mappend` fmap reRule (choCombinators accumho),-        choHoMap = Map.singleton (show mod) aho `mappend` choHoMap accumho-        }------- | this is called on parsed, typechecked haskell code to convert it to the internal representation--coreMini = dump FD.CoreMini-corePass = dump FD.CorePass-coreSteps = dump FD.CoreSteps-miniCorePass = coreMini && corePass-miniCoreSteps = coreMini && coreSteps---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 = do-    -- some useful values-    let allHo = ho `mappend` ho'-        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 dataTable = toDataTable (getConstructorKinds (hoKinds $ hoBuild ho')) (tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)-        classInstances = deriveClasses (choCombinators cho) dataTable-        fullDataTable = dataTable `mappend` hoDataTable (hoBuild ho)-    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)--    wdump FD.Derived $-        mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) classInstances-    -- initial program-    let prog = program {-            progClassHierarchy = hoClassHierarchy $ hoBuild allHo,-            progDataTable = fullDataTable,-            progExternalNames = choExternalNames cho,-            progModule = head (fsts $ tiDataModules tiData)-            }--    -- Convert Haskell decls to E-    let allAssumps = (tiAllAssumptions tiData `mappend` hoAssumps (hoBuild ho))-        theProps = fromList [ (toId x,y) | (x,y) <- Map.toList $ tiProps tiData]-    -- 'convertDecls' uses its monad for error handling.-    ds' <- convertDecls tiData theProps (hoClassHierarchy $ hoBuild ho') allAssumps  fullDataTable decls-    let ds = [ (v,e) | (v,e) <- classInstances ] ++  [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]- --   sequence_ [lintCheckE onerrNone fullDataTable v e | (_,v,e) <- ds ]---{- SamB 2008.01.09: doing this in E.FromHS is error prone!-    -- Build rules from instances-    let instanceRules = createInstanceRules fullDataTable (hoClassHierarchy $ hoBuild ho')  (ds `mappend` hoEs (hoBuild ho))--}--    -- Build rules from specializations and user specified rules and catalysts-    -- FIXME: 'convertRules' and 'procAllSpecs' use IO for error handling. Use an error monad if they are user errors-    --        otherwise use exceptions and make the calls pure.-    userRules <- convertRules (progModule prog) tiData (hoClassHierarchy  $ hoBuild ho') allAssumps fullDataTable decls-    (nds,specializeRules) <- procAllSpecs (tiCheckedRules tiData) ds--    ds <- return $ ds ++ nds-    wdump FD.CoreInitial $-        mapM_ (\(v,lc) -> printCheckName'' fullDataTable v lc) ds--    -- The only thing this will do is simple variable substitution.-    -- '\a -> \a -> a'  =>  '\a -> \b -> b'.-    -- I don't think any functions depends on such shadowing to be removed.-    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--    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--    let seasoning = freeVars [ rs | (k,rs) <- massocs 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 $ hoExp 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 . List.union rs) c-    prog <- return $ progCombinators_u (map addRule) prog-    cho <- return $ 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 = return . programFloatInward-        } prog--    let fint mprog = do-        let names = pprint [ n | (n,_) <- programDs mprog]-        when coreMini $ putErrLn ("----\n" ++ names)-        let tparms = transformParms { transformPass = "Init", transformDumpProgress = coreMini }---        mprog <- evaluate $ etaAnnotateProgram mprog--        mprog <- simplifyProgram sopt "Init-One" coreMini mprog-        mprog <- barendregtProg 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 = "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 <- barendregtProg mprog-        mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformOperation = typeAnalyze True } mprog--        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = return . programFloatInward } mprog-        mprog <- return $ Demand.analyzeProgram mprog-        lintCheckProgram onerrNone mprog-        mprog <- simplifyProgram sopt "Init-Three-AfterDemand" False mprog-        mprog <- barendregtProg 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 rec = progType mprog in  putErr (if rec then "*" else ".")-        return mprog-    lintCheckProgram onerrNone prog-    progress "Initial optimization pass"--    prog <- programMapProgGroups mempty  fint prog-    progress "!"-    hFlush stdout >> hFlush stderr--    wdump FD.Progress $-        Stats.printLStat (optStatLevel options) "Initial Pass Stats" (progStats prog)-    lintCheckProgram onerrNone prog--    prog <- barendregtProg prog { progStats = mempty }-    prog <- etaExpandProg "Init-Big-One" prog-    prog <- transformProgram tparms {-        transformPass = "Init-Big-One",-        transformCategory = "FloatInward",-        transformOperation = return . programFloatInward-        } prog--    prog <- return $ Demand.analyzeProgram prog-    prog <- simplifyProgram' sopt "Init-Big-One" verbose (IterateMax 4) prog--    wdump FD.Progress $-        Stats.printLStat (optStatLevel options) "Init-Big-One Stats" (progStats prog)--    -- 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 <- barendregtProg mprog-        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = return . programFloatInward } mprog-        mprog <- return $ Demand.analyzeProgram mprog-        mprog <- simplifyProgram sopt "Simplify-Two" coreMini mprog-        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = return . programFloatInward } mprog-        mprog <- return $ 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 <- return $ 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 ".")-        return mprog--    prog <- barendregtProg prog { progStats = mempty }-    prog <- evalStateT (programMapProgGroups mempty optWW prog) (SS.so_boundVars sopt)-    progress "!"-    hFlush stdout >> hFlush stderr-    wdump FD.Progress $-        Stats.printLStat (optStatLevel options) "MainPass Stats" (progStats prog)--    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-        (mod:_) = Map.keys $ hoExports $ hoExp ho'-    return (mempty {-        choHoMap = Map.singleton (show mod) ho' { hoBuild = newHoBuild},-        choCombinators = fromList $ [ (combIdent c,c) | c <- progCombinators prog ],-        choExternalNames = idMapToIdSet newMap,-        choVarMap = newMap-        } `mappend` cho,ho' { hoBuild = newHoBuild })--programPruneUnreachable :: Program -> Program-programPruneUnreachable prog = progCombinators_s ds' prog where-    ds' = reachable (newGraph (progCombinators prog) combIdent freeVars) (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-----idHistogram e = execWriter $ annotate mempty (\id nfo -> tell (Histogram.singleton id) >> return nfo) (\_ -> return) (\_ -> return) e--transTypeAnalyze = transformParms { transformCategory = "typeAnalyze",  transformOperation = typeAnalyze True }--compileModEnv cho = do-    if optMode options == GenerateHo then return () else do--    let dataTable = progDataTable prog-        prog = programUpdate program {-            progCombinators = melems $ choCombinators cho,-            progClassHierarchy = choClassHierarchy cho,-            progDataTable = choDataTable cho-            }-        rules' = Rules $ fromList [ (combIdent x,combRules x) | x <- melems (choCombinators cho), not $ null (combRules x) ]--    -- dump final version of various requested things-    wdump FD.Progress $ putStrLn " --- final versions --- "-    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)-    when (dump FD.ClassSummary) $ do-        putStrLn "  ---- class summary ---- "-        printClassSummary (choClassHierarchy cho)-    when (dump FD.Class) $ do-        putStrLn "  ---- class hierarchy ---- "-        printClassHierarchy (choClassHierarchy cho)-    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'--    when collectPassStats $ do-        Stats.print "PassStats" Stats.theStats-        Stats.clear Stats.theStats---    let mainFunc = parseName Val (maybe "Main.main" snd (optMainFunc options))-    esmap <- programEsMap prog-    (main,mainv) <- getMainFunction dataTable mainFunc esmap-    let ffiExportNames = [tv | tv <- map combHead $  progCombinators prog,-                               name <- tvrName tv,-                               "FE@" `isPrefixOf` show name]-    prog <- return 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 <- barendregtProg prog--    (fn,_,_) <- determineArch-    wdump FD.Progress $ putStrLn $ "Arch: " ++ fn--    let theTarget = ELit litCons { litName = dc_Target, litArgs = [ELit (LitInt targetIndex tEnumzh)], litType = ELit litCons { litName = tc_Target, litArgs = [], litType = eStar } }-        targetIndex = 0-    prog <- return $ runIdentity $ flip programMapDs prog $ \(t,e) -> return $ if tvrIdent t == toId v_target then (t { tvrInfo = setProperty prop_INLINE mempty },theTarget) else (t,e)--    wdump FD.Core $ (progress "Before typeAnalyze:" >> printProgram prog)-    prog <- if (fopts FO.TypeAnalysis) then do typeAnalyze False prog else return prog-    when (verbose) $ do putStrLn "Type analyzed methods"-                        flip mapM_ (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-    wdump FD.Core $ (progress "Before expanding method placeholders:" >> printProgram 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---    unless (fopts FO.GlobalOptimize) $ do-        prog <- programPrune prog-        prog <- barendregtProg prog-        wdump FD.CoreBeforelift $ printProgram prog-        prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog-        wdump FD.CoreAfterlift $ printProgram prog -- printCheckName dataTable (programE prog)-        compileToGrin prog-        cleanUp-        exitSuccess---    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterMethod", transformDumpProgress = verbose } prog-    prog <- barendregtProg prog---    prog <- simplifyProgram SS.emptySimplifyOpts "Main-One" verbose prog-    prog <- barendregtProg prog---    prog <- etaExpandProg "Main-AfterOne" prog-    prog <- barendregtProg prog-    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog---    prog <- barendregtProg prog-    prog <- simplifyProgram SS.emptySimplifyOpts "Main-Two" verbose prog-    prog <- barendregtProg prog---    -- run optimization again with no rules enabled--    -- delete rules-    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-    prog <- barendregtProg 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 <- return $ 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 <- barendregtProg prog-    prog <- return $ runIdentity $ programMapBodies (return . cleanupE) prog--    wdump FD.CoreBeforelift $ printProgram prog-    prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog--    wdump FD.CoreAfterlift $ printProgram 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)--    when collectPassStats $ do-        Stats.print "PassStats" Stats.theStats-        Stats.clear Stats.theStats--    compileToGrin prog-    cleanUp-        where isOptMode = (==) (optMode options)-              rm x    = P.catch (mapM_ removeFile x) (const $ return ())-              cleanUp = unless (isOptMode KeepTmpFiles) $ do-                          let n = optOutName options-                          -- FIXME: do this better-                          unless (isOptMode GenerateHo || -                                  isOptMode GenerateHoGrin) $ rm [n++".ho"]-                          unless (isOptMode GenerateC) $ rm [n ++ "_code.c"]---- | 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.--- --- also, all rules are deleted.-boxifyProgram :: Monad m => Program -> m Program-boxifyProgram prog = ans where-    ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog)-    f (t,e) = do---        putStrLn $ ">>> " ++ pprint t-        e <- g e-        return (tv t,e)-    tv t = t { tvrType = boxify (tvrType t) }-    g e = do-  --      putStrLn $ "g: " ++ pprint e-        emapEG g (return . boxify) e -- (\e -> do putStrLn ("box: " ++ pprint e) ; return $ boxify e) e-    boxify t | Just e <- followAlias (progDataTable prog) t = boxify e-    boxify (EPi t e) = EPi t { tvrType = boxify (tvrType t) } (boxify e)-    boxify v@EVar {} | canBeBox v = mktBox (getType v)-    boxify (ELit lc) = ELit lc { litArgs = map boxify (litArgs lc) }---    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) = EAp (boxify a) (boxify b)-    boxify s@ESort {} = 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) | not (isEmptyId v), v `notMember` freeIds e = f (ELam t { tvrIdent = emptyId } e)-    f (EPi t@TVr { tvrIdent = v } e) | not (isEmptyId v), v `notMember` freeIds e = f (EPi t { tvrIdent = emptyId } e)-    f ec@ECase { eCaseBind = t@TVr { tvrIdent = v } } | not (isEmptyId v), v `notMember` (freeVars (caseBodies ec)::IdSet) = f ec { eCaseBind = t { tvrIdent = emptyId } }-    f e = emapEG f f e--simplifyParms = transformParms {-    transformDumpProgress = verbose,-    transformCategory = "Simplify",-    transformPass = "Grin",-    transformOperation = evaluate . Grin.SSimplify.simplify,-    transformIterate = IterateDone-    }--compileToGrin prog = do-    stats <- Stats.new-    progress "Converting to Grin..."-    prog <- return $ atomizeApps True prog-    wdump FD.CoreMangled $ printProgram prog-    x <- Grin.FromE.compile (Grin.FromE.disambiguateProgram prog)-    when verbose $ Stats.print "Grin" Stats.theStats-    wdump FD.GrinInitial $ do dumpGrin "initial" x-    --x <- return $ normalizeGrin x-    x <- transformGrin simplifyParms x-    wdump FD.GrinNormalized $ do dumpGrin "normalized" x-    lintCheckGrin x-    let pushGrin grin = do-            grin <- transformGrin simplifyParms grin-            nf   <- mapMsnd (grinPush undefined) (grinFuncs grin)-            return $ setGrinFunctions nf grin--        opt s grin = do-            stats' <- Stats.new-            let fop grin = do Grin.Simplify.simplify stats' grin-                tparms = transformParms {-                    transformDumpProgress = verbose,-                    transformCategory = s,-                    transformPass = "Grin",-                    transformOperation = fop-                    }-            grin <- transformGrin tparms grin-            t' <- Stats.isEmpty stats'-            wdump FD.Progress $ Stats.print s stats'-            Stats.combine stats stats'-            case t' of-                True -> return grin-                False -> opt s grin--    x <- deadCode stats (grinEntryPointNames x) x  -- XXX-    x <- evaluate $ Grin.SSimplify.simplify x-    --x <- transformGrin simplifyParms x--    x <- pushGrin x-    x <- opt "Optimization" x-    lintCheckGrin x-    x <- grinSpeculate x-    lintCheckGrin x--    x <- deadCode stats (grinEntryPointNames x) x  -- XXX-    --x <- transformGrin simplifyParms x--    x <- opt "Optimization" x-    --lintCheckGrin x-    x <- evaluate $ Grin.SSimplify.simplify x--    wdump FD.OptimizationStats $ Stats.print "Optimization" stats--    wdump FD.GrinPreeval $ dumpGrin "preeval" x-    x <- nodeAnalyze x-    lintCheckGrin x-    x <- createEvalApply x-    lintCheckGrin x-    wdump FD.GrinPosteval $ dumpGrin "posteval" x-    x <- evaluate $ Grin.SSimplify.simplify x--    lintCheckGrin x-    x <- transformGrin devolveTransform x-    x <- opt "After Devolve Optimization" x-    x <- transformGrin simplifyParms x-    x <- return $ twiddleGrin x-    dumpFinalGrin x-    -- don't generate C if we only ask for Ho and Grin files-    compileGrinToC x--dumpFinalGrin grin = do-    wdump FD.GrinGraph $ do-        let dot = graphGrin grin-            fn = optOutName options-        writeFile (fn ++ "_grin.dot") dot-    wdump FD.Grin $ dumpGrin "final" grin-----compileGrinToC grin | optMode options `elem` [GenerateExe-                                             ,GenerateC-                                             ,KeepTmpFiles] = do-    let (cg,rls) = FG2.compileGrin grin-    let fn = optOutName options-    let cf = (fn ++ "_code.c")-    progress ("Writing " ++ show cf)-    (argstring,sversion) <- getArgString-    let-        boehmOpts | fopts FO.Boehm = ["-D_LHC_GC=1", "-lgc"]-                  | otherwise = []-        profileOpts | fopts FO.Profile = ["-D_LHC_PROFILE=1"]-                  | otherwise = []-        comm = shellQuote $ [optCC options, "-std=gnu99", "-D_GNU_SOURCE", "-falign-functions=4", "-ffast-math"-                            , "-Wshadow", "-Wextra", "-Wall", "-Wno-unused-parameter", "-o", fn, cf ] ++-                            (map ("-l" ++) rls) ++ debug ++ unsafe ++ optCCargs options  ++ boehmOpts ++ profileOpts-        debug = if fopts FO.Debug then ["-g"] else ["-fomit-frame-pointer","-O3"]-        unsafe = if fopts FO.Unsafe then ["-DNDEBUG"] else []-        globalvar n c = "char " ++ n ++ "[] = \"" ++ c ++ "\";"-        compileC = do -          progress ("Running: " ++ comm)-          r <- System.system comm-          when (r /= System.ExitSuccess) $ fail "C code did not compile."-    writeFile cf $ unlines [ globalvar "lhc_c_compile" comm-                           , globalvar "lhc_command" argstring -                           , globalvar "lhc_version" sversion,"",cg ]-    -- only compile when we specify GenerateExe or KeepTmpFiles, otherwise we just emit C-    when (optMode options `elem` [KeepTmpFiles, GenerateExe]) compileC-compileGrinToC grin | otherwise = return ()--dumpCore pname prog = do-    let fn = optOutName options ++ "_" ++ pname ++ ".lhc_core"-    putErrLn $ "Writing: " ++ fn-    h <- IO.openFile fn IO.WriteMode-    (argstring,sversion) <- getArgString-    IO.hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]-    hPrintProgram h prog-    IO.hClose h-    wdump FD.Core $ do-        putErrLn $ "v-- " ++ pname ++ " Core"-        printProgram prog-        putErrLn $ "^-- " ++ pname ++ " Core"--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-            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 }---- 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-    when dodump $ putErrLn $ "-- " ++ name-    when (dodump && corePass) $ printProgram prog-    wdump FD.ESize $ printESize ("Before "++name) prog-    let istat = progStats prog-    let ferr e = do-        putErrLn $ "\n>>> Exception thrown"-        putErrLn $ "\n>>> Before " ++ name-        printProgram prog-        putErrLn $ "\n>>>"-#if BASE4-        putErrLn (show (e::SomeException))-#else-        putErrLn (show e)-#endif-        maybeDie-        return prog-    prog' <- Control.Exception.catch (transformOperation tp prog { progStats = mempty }) ferr-    let estat = progStats prog'-        onerr = do-            putErrLn $ "\n>>> Before " ++ name-            printProgram prog-            Stats.printStat name estat-            putErrLn $ "\n>>> After " ++ name-    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 collectPassStats $ 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' }---------typecheck dataTable e = case inferType dataTable [] e of-    Left ss -> do-        putErrLn (render $ ePretty e)-        putErrLn $ "\n>>> internal error:\n" ++ unlines (intersperse "----" $ tail ss)-        maybeDie-        return Unknown-    Right v -> return v--maybeDie = case optKeepGoing options of-    True -> return ()-    False -> putErrDie "Internal Error"--onerrNone :: IO ()-onerrNone = return ()----lintCheckE onerr dataTable tvr e | flint = case 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) | not $ idIsNamed 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 $ melems (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))-        --putErrLn (show ids)-        maybeDie-lintCheckProgram _ _ = return ()---printCheckName' dataTable tvr e = do-    putErrLn (show $ tvrInfo tvr)-    putErrLn  ( render $ hang 4 (pprint tvr <+> equals <+> pprint e <+> text "::") )-    ty <- typecheck dataTable e-    putErrLn  ( render $ indent 4 (pprint ty))---printESize :: String -> Program -> IO ()-printESize str prog = putErrLn $ str ++ " program e-size: " ++ show (eSize (programE prog))---
− src/Name/Id.hs 
@@ -1,263 +0,0 @@-module Name.Id(-    Id(),-    IdMap(),-    IdNameT(),-    IdSet(),-    addBoundNamesIdMap,-    addBoundNamesIdSet,-    addNamesIdSet,-    idMapToIdSet,-    idNameBoundNames,-    idNameUsedNames,-    etherialIds,-    isEtherialId,-    isInvalidId,-    idSetToIdMap,-    mapMaybeIdMap,-    idSetFromList,-    idToInt,-    idIsNamed,-    anonymous,-    idSetFromDistinctAscList,-    idMapFromList,-    idMapFromDistinctAscList,-    idSetToList,-    idMapToList,-    isEmptyId,-    emptyId,-    sillyId,-    newIds,-    newId,-    runIdNameT',-    runIdNameT,-    toId,-    fromId-    )where--import qualified Control.Monad.State as State-import Control.Monad.Reader-import Data.Traversable-import Data.Foldable-import Data.Monoid-import Data.Typeable-import System.Random-import Data.Bits-import Data.Maybe (isJust)-import qualified Data.Map  as Map-import qualified Data.Set as Set--import StringTable.Atom-import Util.HasSize-import Util.Inst()-import Util.NameMonad-import Util.SetLike as S-import Name.Name-import Doc.PPrint-import Doc.DocLike--import Data.DeriveTH-import Data.Derive.All-import Data.Binary--data Id = Empty                -- Empty binding. Like '\ _ -> ...'.-        | Etherial Int         -- Special ids used for typechecking. They should never be exposed to the user.-        | Anonymous Int        -- Anonymous id created by the compiler.-        | Named Name           -- Named id created mostly by the user.-          deriving (Eq,Ord)--$(derive makeBinary ''Id)--instance Show Id where-    showsPrec n (Anonymous i) = showsPrec n i-    showsPrec n (Named x) = showsPrec n x-    showsPrec n (Etherial i) = showsPrec n (-i)-    showsPrec n Empty = showsPrec n "_"--instance DocLike d => PPrint d Id where-    pprint (Anonymous i) = pprint i-    pprint (Named n) = pprint n-    pprint (Etherial i) = pprint (-i)-    pprint Empty = pprint "_"---- IdSet--toId :: Name -> Id-toId x = Named x---toId x = Id (fromAtom (toAtom x))--fromId :: Monad m => Id -> m Name-fromId (Named n) = return n-fromId i = fail $ "Name.fromId: not a name " ++ show i---newtype IdSet = IdSet (Set.Set Id)-    deriving(Typeable,Monoid,HasSize,SetLike,BuildSet Id,ModifySet Id,IsEmpty,Eq,Ord,Binary)---idSetToList :: IdSet -> [Id]-idSetToList (IdSet is) = Set.toList is--idMapToList :: IdMap a -> [(Id,a)]-idMapToList (IdMap is) = Map.toList is--idToInt :: Id -> Int-idToInt (Anonymous i) = i-idToInt (Named n) = fromAtom (toAtom n)-idToInt (Etherial i) = -i-idToInt Empty = 0--idIsNamed :: Id -> Bool-idIsNamed = isJust . fromId--mapMaybeIdMap :: (a -> Maybe b) -> IdMap a -> IdMap b-mapMaybeIdMap fn (IdMap m) = IdMap (Map.mapMaybe fn m)----- IdMap--newtype IdMap a = IdMap (Map.Map Id a)-    deriving(Typeable,Monoid,HasSize,SetLike,BuildSet (Id,a),MapLike Id a,Functor,Traversable,Foldable,IsEmpty,Eq,Ord,Binary)---idSetToIdMap :: (Id -> a) -> IdSet -> IdMap a-idSetToIdMap f (IdSet is) = IdMap $ Map.fromDistinctAscList [ (x,f x) |  x <- Set.toAscList is]--idMapToIdSet :: IdMap a -> IdSet-idMapToIdSet (IdMap im) = IdSet $ (Map.keysSet im)----- | Name monad transformer.-newtype IdNameT m a = IdNameT (State.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---- | Get bound and used names-idNameBoundNames :: Monad m => IdNameT m IdSet-idNameBoundNames = IdNameT $ do-    (_used,bound) <- State.get-    return bound-idNameUsedNames :: Monad m => IdNameT m IdSet-idNameUsedNames = IdNameT $  do-    (used,_bound) <- State.get-    return used---- | Run the name monad transformer.-runIdNameT :: (Monad m) => IdNameT m a -> m a-runIdNameT (IdNameT x) = liftM fst $ State.runStateT x (mempty,mempty)--runIdNameT' :: (Monad m) => IdNameT m a -> m (a,IdSet)-runIdNameT' (IdNameT x) = do-    (r,(used,bound)) <- State.runStateT x (mempty,mempty)-    return (r,bound)--fromIdNameT (IdNameT x) = x--instance GenName Id where-    genNames i = map anonymous [st, st + 2 ..]  where-        st = abs i + 2 + abs i `mod` 2--instance Monad m => NameMonad Id (IdNameT m) where-    addNames ns = IdNameT $ do-        State.modify (\ (used,bound) -> (fromList ns `union` used, bound) )-    addBoundNames ns = IdNameT $ do-        let nset = fromList ns-        State.modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )-    uniqueName n = IdNameT $ do-        (used,bound) <- State.get-        if n `member` bound then fromIdNameT newName else State.put (insert n used,insert n bound) >> return n-    newNameFrom vs = IdNameT $ do-        (used,bound) <- State.get-        let f (x:xs)-                | x `member` used = f xs-                | otherwise = x-            f [] = error "newNameFrom: finite list!"-            nn = f vs-        State.put (insert nn used, insert nn bound)-        return nn-    newName  = IdNameT $ do-        (used,bound) <- State.get-        let genNames i = map anonymous [st, st + 2 ..]  where-                st = abs i + 2 + abs i `mod` 2-        fromIdNameT $ newNameFrom  (genNames (size used + size bound))--addNamesIdSet nset = IdNameT $ do-    State.modify (\ (used,bound) -> (nset `union` used, bound) )-addBoundNamesIdSet nset = IdNameT $ do-    State.modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )--addBoundNamesIdMap nmap = IdNameT $ do-    State.modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where-        nset = idMapToIdSet nmap--idSetFromDistinctAscList :: [Id] -> IdSet-idSetFromDistinctAscList ids = IdSet (Set.fromDistinctAscList ids)--idSetFromList :: [Id] -> IdSet-idSetFromList ids = IdSet (Set.fromList ids)--idMapFromList :: [(Id,a)] -> IdMap a-idMapFromList ids = IdMap (Map.fromList ids)--idMapFromDistinctAscList :: [(Id,a)] -> IdMap a-idMapFromDistinctAscList ids = IdMap (Map.fromDistinctAscList ids)---instance Show IdSet where-    showsPrec n is = showsPrec n $ map f (idSetToList is) where-        f n =  maybe (toAtom ('x':show n)) (toAtom . show) (fromId n)--instance Show v => Show (IdMap v) where-    showsPrec n is = showsPrec n $ map f (idMapToList is) where-        f (n,v) =  (maybe (toAtom ('x':show n)) (toAtom . show) (fromId n),v)---- Id types--- odd - an atom--- 0 - special, indicating lack of binding--- negative - etherial id, used as placeholder within algorithms--- positive and even - arbitrary numbers.--etherialIds :: [Id]-etherialIds = map Etherial [2, 3 ..  ]--isEtherialId Etherial{} = True-isEtherialId _ = False--isInvalidId Etherial{} = True-isInvalidId Empty = True-isInvalidId _ = False--isEmptyId :: Id -> Bool-isEmptyId Empty = True-isEmptyId _ = False--emptyId :: Id-emptyId = Empty--anonymous :: Int -> Id-anonymous x | x <= 0    = error "Anonymous variables must be positive numbers."-            | otherwise = Anonymous x--sillyId :: Id-sillyId = Etherial 1---- | 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 ids = [ anonymous i | i <- [s ..] , anonymous i `notMember` ids ] where-    s = 1 + (size 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 ls where-    ls = map anonymous $ map mask $ randoms (mkStdGen seed)-    mask x = x .&. 0x0FFFFFFE----
− src/Name/Name.hs 
@@ -1,218 +0,0 @@-module Name.Name(-    NameType(..),-    Name(..),-    nameName,-    nameType,-    getModule,-    toUnqualified,-    qualifyName,-    ToName(..),-    fromTypishHsName,-    fromValishHsName,-    parseName,-    ffiExportName,-    isConstructorLike,---    toId,---    fromId,-    Module,-    isTypeNamespace,-    isValNamespace,-    mainModule,-    nameParts,-    mapName,-    setModule-    ) where--import Data.Char-import Data.Typeable--import StringTable.Atom-import Data.Binary-import C.FFI-import Doc.DocLike-import Doc.PPrint-import GenUtil-import FrontEnd.HsSyn--import Data.Word-import Data.ByteString (ByteString)--import Debug.Trace--data NameType =-    TypeConstructor-    | DataConstructor-    | ClassName-    | TypeVal-    | Val-    | SortName-    | FieldLabel-    | RawType-    deriving(Ord,Eq,Enum,Read,Show)---data Name = Name { nameAtom   :: Atom-                 , nameHash   :: Word32-                 , nameType   :: NameType-                 , nameModule :: Maybe String-                 , nameIdent  :: String-                 }-    deriving(Typeable) --,Eq,Binary,ToAtom,FromAtom)--nameString :: Name -> ByteString-nameString = fromAtom . nameAtom--instance Binary Name where-    put = put . nameAtom-    get = fmap fromAtom get--instance FromAtom Name where-    fromAtom atom = let (nt, mod, i) = genNameParts atom-                        name = Name { nameAtom = atom-                                    , nameHash = hash32 atom-                                    , nameType = nt-                                    , nameModule = mod-                                    , nameIdent = i }-                    in name-instance ToAtom Name where-    toAtom = nameAtom--instance Eq Name where-    a == b = nameAtom a == nameAtom b-    a /= b = nameAtom a /= nameAtom b---- Comparing ByteString's is relatively slow. Try to avoid it.-instance Ord Name where-   a `compare` b = case nameHash a `compare` nameHash b of-                     EQ -> if nameAtom a == nameAtom b-                           then EQ-                           else nameString a `compare` nameString b-                     other -> other--isTypeNamespace TypeConstructor = True-isTypeNamespace ClassName = True-isTypeNamespace TypeVal = True-isTypeNamespace _ = False--isValNamespace DataConstructor = True-isValNamespace Val = True-isValNamespace _ = False--isConstructorLike xs@(x:_) =  isUpper x || x `elem` ":("  || xs == "->"-isConstructorLike [] = error "isConstructorLike: empty"--fromTypishHsName, fromValishHsName :: HsName -> Name-fromTypishHsName name-    | isUpper x || x `elem` ":(" = toName TypeConstructor name-    | otherwise = toName TypeVal name-    where (x:_) = (hsIdentString . hsNameIdent  $ name)-fromValishHsName name-    | isUpper x || x `elem` ":(" = toName DataConstructor name-    | otherwise = toName Val name-    where (x:_) = (hsIdentString . hsNameIdent  $ name)--createName _ "" i = error $ "createName: empty module "  ++ i-createName _ m "" = error $ "createName: empty ident "   ++ m-createName t m i = fromAtom $  toAtom $ (chr $  ord '1' + fromEnum t):m ++ ";" ++ i-createUName :: NameType -> String -> Name-createUName _ "" = error $ "createUName: empty ident"-createUName t i =  fromAtom $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i--class ToName a where-    toName :: NameType -> a -> Name-    fromName :: Name -> (NameType, a)--instance ToName HsName where-    toName nt n = m where-        i = hsIdentString $ hsNameIdent n-        m | Qual (Module m) _ <- n = createName nt m i-          | otherwise = createUName nt i-    fromName n = (nameType n, nameName n)--instance ToName (String,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,("",i))--instance ToName (Maybe String,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 (Maybe Module,String) where-    toName nt (Just (Module m),i) = createName nt m i-    toName nt (Nothing,i) = createUName nt i-    fromName n = case nameParts n of-        (nt,a,b) -> (nt,(fmap Module a,b))--instance ToName String where-    toName nt i = createUName nt i-    fromName n = (nameType n, mi ) where-        mi = case snd $ fromName n of-            (Just m,i) -> m ++ "." ++ i-            (Nothing,i) -> i---getModule :: Monad m => Name -> m Module-getModule n = case nameParts n of-    (_,Just m,_)  -> return (Module m)-    _ -> fail "Name is unqualified."--toUnqualified :: Name -> Name-toUnqualified n = case nameParts n of-    (_,Nothing,_) -> n-    (t,Just _,i) -> toName t 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---genNameType :: Atom -> NameType-genNameType a = toEnum $ fromIntegral ( a `unsafeByteIndex` 0) - ord '1'--nameName :: Name -> HsName-nameName (Name _ _ _ (Just mod) i)-    = Qual (Module mod) (HsIdent i)-nameName (Name _ _ _ Nothing i)-    = UnQual $ HsIdent i--nameParts :: Name -> (NameType, Maybe String, String)-nameParts name = (nameType name, nameModule name, nameIdent name)--genNameParts :: Atom -> (NameType,Maybe String,String)-genNameParts n = f $ tail (fromAtom n) where-    f (';':xs) = (genNameType n,Nothing,xs)-    f xs = (genNameType n,Just a,b) where-        (a,_:b) = span (/= ';') xs--instance Show Name where-    show a = show $ nameName a--instance DocLike d => PPrint d Name  where-    pprint n = text (show n)--mapName :: (String -> String,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 :: String),g i)--mainModule = Module "Main@"--ffiExportName :: FfiExport -> Name-ffiExportName (FfiExport cn _ cc) = toName Val ("FE@", show cc ++ "." ++ cn)-
− src/Name/Names.hs 
@@ -1,112 +0,0 @@--- | 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 Char(isDigit)--import Name.VConsts-import Name.Name-import Name.Prim--instance TypeNames Name where-    tInt = tc_Int-    tBool = tc_Bool-    tInteger = tc_Integer-    tChar = tc_Char-    tStar = s_Star-    tHash = s_Hash-    tUnit = tc_Unit-    tIntzh = rt_bits32-    tEnumzh = rt_bits16-    tCharzh = rt_bits32-    tIntegerzh = rt_bits_max_-    tWorld__ = tc_World__--instance ConNames Name where---    vTrue = dc_True---    vFalse = dc_False-    vEmptyList = dc_EmptyList-    vUnit = dc_Unit-    vCons = dc_Cons----- Tuple handling----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 == "Lhc.Basics" = fromTupname (nn::String) where-        (_,(m,nn)) = fromName name-    fromTupname _ = fail "not a tuple"------ The constructors---tc_Arrow = toName TypeConstructor  ("Lhc.Basics","->")-tc_Int__ = toName TypeConstructor  ("Lhc.Prim","Int__")-tc_Array__ = toName TypeConstructor  ("Lhc.Array","Array__")-tc_MutArray__ = toName TypeConstructor  ("Lhc.Array","MutArray__")-tc_Ref__ = toName TypeConstructor ("Data.IORef","Ref__")---tc_Boolzh = toName TypeConstructor ("Lhc.Order","Bool#")-tc_List = toName TypeConstructor  ("Lhc.Prim","[]")---s_Star = toName SortName ("Lhc@","*")-s_Hash = toName SortName ("Lhc@","#")---sFuncNames = FuncNames {-    func_bind = v_bind,-    func_bind_ = v_bind_,-    func_return = v_return,-    func_concatMap = v_concatMap,-    func_fromInteger = v_fromInteger,-    func_fromInt = v_fromInt,-    func_fromRational = v_fromRational,-    func_negate = v_negate,-    func_leq = v_leq,-    func_geq = v_geq,-    func_lt = v_lt,-    func_gt = v_gt,-    func_compare = v_compare,-    func_equals = v_equals,-    func_neq = v_neq,-    func_fromEnum = v_fromEnum,-    func_toEnum = v_toEnum,-    func_minBound = v_minBound,-    func_maxBound = v_maxBound,-    func_enumFrom = v_enumFrom,-    func_enumFromThen = v_enumFromThen,-    func_range = v_range,-    func_index = v_index,-    func_inRange = v_inRange,-    func_runExpr = v_runExpr,-    func_runRaw = v_runRaw,-    func_runMain = v_runMain,-    func_runNoWrapper = v_runNoWrapper-    }----
− src/Name/Prim.hs 
@@ -1,349 +0,0 @@-{- Generated by utils/op_names.pl -}--module Name.Prim where--import Name.Name--{-# NOINLINE tc_Int #-}-tc_Int = toName TypeConstructor ("Lhc.Prim","Int")-{-# NOINLINE dc_Int #-}-dc_Int = toName DataConstructor ("Lhc.Prim","Int")-{-# NOINLINE tc_Integer #-}-tc_Integer = toName TypeConstructor ("Lhc.Basics","Integer")-{-# NOINLINE dc_Integer #-}-dc_Integer = toName DataConstructor ("Lhc.Basics","Integer")-{-# NOINLINE tc_Int8 #-}-tc_Int8 = toName TypeConstructor ("Data.Int","Int8")-{-# NOINLINE dc_Int8 #-}-dc_Int8 = toName DataConstructor ("Data.Int","Int8")-{-# NOINLINE tc_Int16 #-}-tc_Int16 = toName TypeConstructor ("Data.Int","Int16")-{-# NOINLINE dc_Int16 #-}-dc_Int16 = toName DataConstructor ("Data.Int","Int16")-{-# NOINLINE tc_Int32 #-}-tc_Int32 = toName TypeConstructor ("Data.Int","Int32")-{-# NOINLINE dc_Int32 #-}-dc_Int32 = toName DataConstructor ("Data.Int","Int32")-{-# NOINLINE tc_Int64 #-}-tc_Int64 = toName TypeConstructor ("Data.Int","Int64")-{-# NOINLINE dc_Int64 #-}-dc_Int64 = toName DataConstructor ("Data.Int","Int64")-{-# NOINLINE tc_IntMax #-}-tc_IntMax = toName TypeConstructor ("Data.Int","IntMax")-{-# NOINLINE dc_IntMax #-}-dc_IntMax = toName DataConstructor ("Data.Int","IntMax")-{-# NOINLINE tc_IntPtr #-}-tc_IntPtr = toName TypeConstructor ("Data.Int","IntPtr")-{-# NOINLINE dc_IntPtr #-}-dc_IntPtr = toName DataConstructor ("Data.Int","IntPtr")-{-# NOINLINE tc_Word #-}-tc_Word = toName TypeConstructor ("Data.Word","Word")-{-# NOINLINE dc_Word #-}-dc_Word = toName DataConstructor ("Data.Word","Word")-{-# NOINLINE tc_Word8 #-}-tc_Word8 = toName TypeConstructor ("Data.Word","Word8")-{-# NOINLINE dc_Word8 #-}-dc_Word8 = toName DataConstructor ("Data.Word","Word8")-{-# NOINLINE tc_Word16 #-}-tc_Word16 = toName TypeConstructor ("Data.Word","Word16")-{-# NOINLINE dc_Word16 #-}-dc_Word16 = toName DataConstructor ("Data.Word","Word16")-{-# NOINLINE tc_Word32 #-}-tc_Word32 = toName TypeConstructor ("Data.Word","Word32")-{-# NOINLINE dc_Word32 #-}-dc_Word32 = toName DataConstructor ("Data.Word","Word32")-{-# NOINLINE tc_Word64 #-}-tc_Word64 = toName TypeConstructor ("Data.Word","Word64")-{-# NOINLINE dc_Word64 #-}-dc_Word64 = toName DataConstructor ("Data.Word","Word64")-{-# NOINLINE tc_WordMax #-}-tc_WordMax = toName TypeConstructor ("Data.Word","WordMax")-{-# NOINLINE dc_WordMax #-}-dc_WordMax = toName DataConstructor ("Data.Word","WordMax")-{-# NOINLINE tc_WordPtr #-}-tc_WordPtr = toName TypeConstructor ("Data.Word","WordPtr")-{-# NOINLINE dc_WordPtr #-}-dc_WordPtr = toName DataConstructor ("Data.Word","WordPtr")-{-# NOINLINE tc_CChar #-}-tc_CChar = toName TypeConstructor ("Foreign.C.Types","CChar")-{-# NOINLINE dc_CChar #-}-dc_CChar = toName DataConstructor ("Foreign.C.Types","CChar")-{-# NOINLINE tc_CShort #-}-tc_CShort = toName TypeConstructor ("Foreign.C.Types","CShort")-{-# NOINLINE dc_CShort #-}-dc_CShort = toName DataConstructor ("Foreign.C.Types","CShort")-{-# NOINLINE tc_CInt #-}-tc_CInt = toName TypeConstructor ("Foreign.C.Types","CInt")-{-# NOINLINE dc_CInt #-}-dc_CInt = toName DataConstructor ("Foreign.C.Types","CInt")-{-# NOINLINE tc_CUInt #-}-tc_CUInt = toName TypeConstructor ("Foreign.C.Types","CUInt")-{-# NOINLINE dc_CUInt #-}-dc_CUInt = toName DataConstructor ("Foreign.C.Types","CUInt")-{-# NOINLINE tc_CSize #-}-tc_CSize = toName TypeConstructor ("Foreign.C.Types","CSize")-{-# NOINLINE dc_CSize #-}-dc_CSize = toName DataConstructor ("Foreign.C.Types","CSize")-{-# NOINLINE tc_CWchar #-}-tc_CWchar = toName TypeConstructor ("Foreign.C.Types","CWchar")-{-# NOINLINE dc_CWchar #-}-dc_CWchar = toName DataConstructor ("Foreign.C.Types","CWchar")-{-# NOINLINE tc_CWint #-}-tc_CWint = toName TypeConstructor ("Foreign.C.Types","CWint")-{-# NOINLINE dc_CWint #-}-dc_CWint = toName DataConstructor ("Foreign.C.Types","CWint")-{-# NOINLINE tc_CTime #-}-tc_CTime = toName TypeConstructor ("Foreign.C.Types","CTime")-{-# NOINLINE dc_CTime #-}-dc_CTime = toName DataConstructor ("Foreign.C.Types","CTime")--{-# 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_bits8 #-}-rt_bits8 = toName RawType "bits8"-{-# NOINLINE rt_bits_int_ #-}-rt_bits_int_ = toName RawType "bits<int>"-{-# NOINLINE rt_bits_max_ #-}-rt_bits_max_ = toName RawType "bits<max>"-{-# NOINLINE rt_bits_ptr_ #-}-rt_bits_ptr_ = toName RawType "bits<ptr>"-{-# NOINLINE rt_bits_short_ #-}-rt_bits_short_ = toName RawType "bits<short>"-{-# NOINLINE rt_bits_size_t_ #-}-rt_bits_size_t_ = toName RawType "bits<size_t>"-{-# NOINLINE rt_bits_time_t_ #-}-rt_bits_time_t_ = toName RawType "bits<time_t>"-{-# NOINLINE tc_JumpPoint #-}-tc_JumpPoint = toName TypeConstructor ("Lhc.JumpPoint","JumpPoint")-{-# NOINLINE tc_Char #-}-tc_Char = toName TypeConstructor ("Lhc.Prim","Char")-{-# NOINLINE tc_IO #-}-tc_IO = toName TypeConstructor ("Lhc.Prim","IO")-{-# NOINLINE tc_World__ #-}-tc_World__ = toName TypeConstructor ("Lhc.Prim","World__")-{-# NOINLINE tc_Bool #-}-tc_Bool = toName TypeConstructor ("Lhc.Order","Bool")-{-# NOINLINE tc_Target #-}-tc_Target = toName TypeConstructor ("Lhc.Options","Target")-{-# NOINLINE tc_Ptr #-}-tc_Ptr = toName TypeConstructor ("Lhc.Addr","Ptr")-{-# NOINLINE tc_Addr #-}-tc_Addr = toName TypeConstructor ("Lhc.Addr","Addr")-{-# NOINLINE tc_FunAddr #-}-tc_FunAddr = toName TypeConstructor ("Lhc.Addr","FunAddr")-{-# NOINLINE tc_Ratio #-}-tc_Ratio = toName TypeConstructor ("Lhc.Num","Ratio")-{-# NOINLINE tc_Unit #-}-tc_Unit = toName TypeConstructor ("Lhc.Basics","()")-{-# NOINLINE tc_Float #-}-tc_Float = toName TypeConstructor ("Lhc.Float","Float")-{-# NOINLINE tc_Double #-}-tc_Double = toName TypeConstructor ("Lhc.Float","Double")-{-# NOINLINE tc_CLong #-}-tc_CLong = toName TypeConstructor ("Foreign.C.Types","CLong")-{-# NOINLINE tc_CSChar #-}-tc_CSChar = toName TypeConstructor ("Foreign.C.Types","CSChar")-{-# NOINLINE tc_CUChar #-}-tc_CUChar = toName TypeConstructor ("Foreign.C.Types","CUChar")-{-# NOINLINE tc_CUShort #-}-tc_CUShort = toName TypeConstructor ("Foreign.C.Types","CUShort")-{-# NOINLINE tc_CULong #-}-tc_CULong = toName TypeConstructor ("Foreign.C.Types","CULong")-{-# NOINLINE tc_Bits1 #-}-tc_Bits1 = toName TypeConstructor ("Lhc.Types","Bits1_")-{-# NOINLINE tc_Bits8 #-}-tc_Bits8 = toName TypeConstructor ("Lhc.Types","Bits8_")-{-# NOINLINE tc_Bits16 #-}-tc_Bits16 = toName TypeConstructor ("Lhc.Types","Bits16_")-{-# NOINLINE tc_Bits32 #-}-tc_Bits32 = toName TypeConstructor ("Lhc.Types","Bits32_")-{-# NOINLINE tc_Bits64 #-}-tc_Bits64 = toName TypeConstructor ("Lhc.Types","Bits64_")-{-# NOINLINE tc_Bits128 #-}-tc_Bits128 = toName TypeConstructor ("Lhc.Types","Bits128_")-{-# NOINLINE tc_BitsPtr #-}-tc_BitsPtr = toName TypeConstructor ("Lhc.Types","BitsPtr_")-{-# NOINLINE tc_BitsMax #-}-tc_BitsMax = toName TypeConstructor ("Lhc.Types","BitsMax_")-{-# NOINLINE tc_BitsSize #-}-tc_BitsSize = toName TypeConstructor ("Lhc.Types","BitsSize_t_")-{-# NOINLINE tc_BitsShort #-}-tc_BitsShort = toName TypeConstructor ("Lhc.Types","BitsShort_")-{-# NOINLINE tc_BitsInt #-}-tc_BitsInt = toName TypeConstructor ("Lhc.Types","BitsInt_")-{-# NOINLINE tc_BitsLong #-}-tc_BitsLong = toName TypeConstructor ("Lhc.Types","BitsLong_")-{-# NOINLINE tc_Float32 #-}-tc_Float32 = toName TypeConstructor ("Lhc.Types","Float32_")-{-# NOINLINE tc_Float64 #-}-tc_Float64 = toName TypeConstructor ("Lhc.Types","Float64_")-{-# NOINLINE tc_Float80 #-}-tc_Float80 = toName TypeConstructor ("Lhc.Types","Float80_")-{-# NOINLINE tc_Float128 #-}-tc_Float128 = toName TypeConstructor ("Lhc.Types","Float128_")-{-# NOINLINE dc_Rational #-}-dc_Rational = toName DataConstructor ("Lhc.Num",":%")-{-# NOINLINE dc_Cons #-}-dc_Cons = toName DataConstructor ("Lhc.Prim",":")-{-# NOINLINE dc_EmptyList #-}-dc_EmptyList = toName DataConstructor ("Lhc.Prim","[]")-{-# NOINLINE dc_Unit #-}-dc_Unit = toName DataConstructor ("Lhc.Basics","()")-{-# NOINLINE dc_Boolzh #-}-dc_Boolzh = toName DataConstructor ("Lhc.Order","Bool#")-{-# NOINLINE dc_Target #-}-dc_Target = toName DataConstructor ("Lhc.Options","Target#")-{-# NOINLINE dc_Char #-}-dc_Char = toName DataConstructor ("Lhc.Prim","Char")-{-# NOINLINE dc_Addr #-}-dc_Addr = toName DataConstructor ("Lhc.Addr","Addr")-{-# NOINLINE class_Eq #-}-class_Eq = toName ClassName ("Lhc.Order","Eq")-{-# NOINLINE class_Ord #-}-class_Ord = toName ClassName ("Lhc.Order","Ord")-{-# NOINLINE class_Enum #-}-class_Enum = toName ClassName ("Lhc.Enum","Enum")-{-# NOINLINE class_Bounded #-}-class_Bounded = toName ClassName ("Lhc.Enum","Bounded")-{-# NOINLINE class_Show #-}-class_Show = toName ClassName ("Lhc.Show","Show")-{-# NOINLINE class_Read #-}-class_Read = toName ClassName ("Lhc.Text","Read")-{-# NOINLINE class_Ix #-}-class_Ix = toName ClassName ("Data.Ix","Ix")-{-# NOINLINE class_Functor #-}-class_Functor = toName ClassName ("Lhc.Monad","Functor")-{-# NOINLINE class_Monad #-}-class_Monad = toName ClassName ("Lhc.Monad","Monad")-{-# NOINLINE class_Num #-}-class_Num = toName ClassName ("Lhc.Num","Num")-{-# NOINLINE class_Real #-}-class_Real = toName ClassName ("Lhc.Num","Real")-{-# NOINLINE class_Integral #-}-class_Integral = toName ClassName ("Lhc.Num","Integral")-{-# NOINLINE class_Fractional #-}-class_Fractional = toName ClassName ("Lhc.Num","Fractional")-{-# NOINLINE class_Floating #-}-class_Floating = toName ClassName ("Lhc.Float","Floating")-{-# NOINLINE class_RealFrac #-}-class_RealFrac = toName ClassName ("Lhc.Float","RealFrac")-{-# NOINLINE class_RealFloat #-}-class_RealFloat = toName ClassName ("Lhc.Float","RealFloat")-{-# 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 v_eqString #-}-v_eqString = toName Val ("Lhc.String","eqString")-{-# NOINLINE v_eqUnpackedString #-}-v_eqUnpackedString = toName Val ("Lhc.String","eqUnpackedString")-{-# NOINLINE v_unpackString #-}-v_unpackString = toName Val ("Lhc.String","unpackString")-{-# NOINLINE v_target #-}-v_target = toName Val ("Lhc.Options","target")-{-# NOINLINE v_error #-}-v_error = toName Val ("Lhc.IO","error")-{-# NOINLINE v_minBound #-}-v_minBound = toName Val ("Lhc.Enum","minBound")-{-# NOINLINE v_maxBound #-}-v_maxBound = toName Val ("Lhc.Enum","maxBound")-{-# NOINLINE v_fail #-}-v_fail = toName Val ("Lhc.Monad","fail")-{-# NOINLINE v_map #-}-v_map = toName Val ("Lhc.Basics","map")-{-# NOINLINE v_and #-}-v_and = toName Val ("Lhc.Order","&&")-{-# NOINLINE v_filter #-}-v_filter = toName Val ("Lhc.List","filter")-{-# NOINLINE v_foldr #-}-v_foldr = toName Val ("Lhc.Basics","foldr")-{-# NOINLINE v_undefined #-}-v_undefined = toName Val ("Lhc.Basics","undefined")-{-# NOINLINE v_bind #-}-v_bind = toName Val ("Lhc.Monad",">>=")-{-# NOINLINE v_bind_ #-}-v_bind_ = toName Val ("Lhc.Monad",">>")-{-# NOINLINE v_return #-}-v_return = toName Val ("Lhc.Monad","return")-{-# NOINLINE v_concatMap #-}-v_concatMap = toName Val ("Lhc.Basics","concatMap")-{-# NOINLINE v_fromInteger #-}-v_fromInteger = toName Val ("Lhc.Num","fromInteger")-{-# NOINLINE v_fromInt #-}-v_fromInt = toName Val ("Lhc.Num","fromInt")-{-# NOINLINE v_fromRational #-}-v_fromRational = toName Val ("Lhc.Num","fromRational")-{-# NOINLINE v_negate #-}-v_negate = toName Val ("Lhc.Num","negate")-{-# NOINLINE v_leq #-}-v_leq = toName Val ("Lhc.Order","<=")-{-# NOINLINE v_geq #-}-v_geq = toName Val ("Lhc.Order",">=")-{-# NOINLINE v_lt #-}-v_lt = toName Val ("Lhc.Order","<")-{-# NOINLINE v_gt #-}-v_gt = toName Val ("Lhc.Order",">")-{-# NOINLINE v_compare #-}-v_compare = toName Val ("Lhc.Order","compare")-{-# NOINLINE v_equals #-}-v_equals = toName Val ("Lhc.Order","==")-{-# NOINLINE v_neq #-}-v_neq = toName Val ("Lhc.Order","/=")-{-# NOINLINE v_fromEnum #-}-v_fromEnum = toName Val ("Lhc.Enum","fromEnum")-{-# NOINLINE v_toEnum #-}-v_toEnum = toName Val ("Lhc.Enum","toEnum")-{-# NOINLINE v_enumFrom #-}-v_enumFrom = toName Val ("Lhc.Enum","enumFrom")-{-# NOINLINE v_enumFromTo #-}-v_enumFromTo = toName Val ("Lhc.Enum","enumFromTo")-{-# NOINLINE v_enumFromThenTo #-}-v_enumFromThenTo = toName Val ("Lhc.Enum","enumFromThenTo")-{-# NOINLINE v_enumFromThen #-}-v_enumFromThen = toName Val ("Lhc.Enum","enumFromThen")-{-# NOINLINE v_succ #-}-v_succ = toName Val ("Lhc.Enum","succ")-{-# NOINLINE v_pred #-}-v_pred = toName Val ("Lhc.Enum","pred")-{-# 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 ("Lhc.Prim","runRaw")-{-# NOINLINE v_runMain #-}-v_runMain = toName Val ("Lhc.IO","runMain")-{-# NOINLINE v_runNoWrapper #-}-v_runNoWrapper = toName Val ("Lhc.Prim","runNoWrapper")-{-# NOINLINE v_enum_succ #-}-v_enum_succ = toName Val ("Lhc.Inst.PrimEnum","enum_succ")-{-# NOINLINE v_enum_pred #-}-v_enum_pred = toName Val ("Lhc.Inst.PrimEnum","enum_pred")-{-# NOINLINE v_enum_from #-}-v_enum_from = toName Val ("Lhc.Inst.PrimEnum","enum_from")-{-# NOINLINE v_enum_fromTo #-}-v_enum_fromTo = toName Val ("Lhc.Inst.PrimEnum","enum_fromTo")-{-# NOINLINE v_enum_fromThen #-}-v_enum_fromThen = toName Val ("Lhc.Inst.PrimEnum","enum_fromThen")-{-# NOINLINE v_enum_fromThenTo #-}-v_enum_fromThenTo = toName Val ("Lhc.Inst.PrimEnum","enum_fromThenTo")-{-# NOINLINE v_enum_toEnum #-}-v_enum_toEnum = toName Val ("Lhc.Inst.PrimEnum","enum_toEnum")--
− src/Name/VConsts.hs 
@@ -1,115 +0,0 @@-module Name.VConsts where--import Data.Traversable-import Data.Foldable-import Control.Applicative-import Data.DeriveTH-import Data.Derive.All---- This is much more verbose/complicated than it needs be.--class TypeNames a where-    tInt :: a-    tRational :: a-    tChar :: a-    tIntzh :: a-    tEnumzh :: a-    tIntegerzh :: a-    tCharzh :: a-    tStar :: a-    tHash :: 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"-    tIntegerzh = error "tIntegerzh"-    tCharzh = error "tCharzh"-    tStar = error "VConsts: tStar"-    tBool = error "tBool"-    tUnit = error "tUnit"-    tString = error "tString"-    tInteger = error "tInteger"-    tHash = error "tHash"-    tWorld__ = error "tWorld"---class ConNames a where-    vTrue :: a-    vFalse :: a-    vEmptyList :: a-    vCons :: a-    vUnit :: a-    vOrdering :: Ordering -> a--    vTrue = error "vTrue"-    vFalse = error "vFalse"-    vEmptyList = error "vEmptyList"-    vCons = error "vCons"-    vUnit = error "vUnit"-    vOrdering x = error $ "v" ++ show x--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 ("Lhc.Basics",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 = ("Lhc.Basics",toTuple n)------- | various functions needed for desugaring.-data FuncNames a = FuncNames {-    func_bind :: a,-    func_bind_ :: a,-    func_return :: a,-    func_concatMap :: a,-    func_equals :: a,-    func_fromInt :: a,-    func_fromInteger :: a,-    func_fromRational :: a,-    func_negate :: a,-    func_runExpr :: a,-    func_runRaw :: a,-    func_runMain :: a,-    func_leq :: a,-    func_geq :: a,-    func_lt :: a,-    func_gt :: a,-    func_compare :: a,-    func_neq :: a,-    func_fromEnum :: a,-    func_toEnum :: a,-    func_minBound :: a,-    func_maxBound :: a,-    func_enumFrom :: a,-    func_enumFromThen :: a,-    func_range :: a,-    func_index :: a,-    func_inRange :: a,-    func_runNoWrapper :: a-    }-$(derive makeFunctor ''FuncNames)-$(derive makeFoldable ''FuncNames)-$(derive makeTraversable ''FuncNames)
− src/Options.hs 
@@ -1,317 +0,0 @@-{-# OPTIONS -w -funbox-strict-fields #-}-module Options(-    processOptions,-    Opt(..),-    options,-    Mode(..),-    putVerbose,-    putVerboseLn,-    getArguments,-    verbose,-    verbose2,-    dump,-    wdump,-    fopts,-    flint,-    fileOptions,-    withOptions,-    withOptionsT,-    getArgString,-    OptM(),-    OptT(),-    OptionMonad(..),-    flagOpt-    ) where--import Control.Monad.Error()    -- IO MonadPlus instance-import Control.Monad.Identity-import Control.Monad.Reader-import qualified Data.Set as S-import Data.List(nub)-import System-import System.Console.GetOpt-import System.IO.Unsafe-import System.Directory--import Data.DeriveTH-import Data.Derive.All-import Util.Gen-import qualified FlagDump-import qualified FlagOpts-import LHCVersion--data Mode = BuildHl String -- ^ Build the specified hl-file given a description file.-          | Version        -- ^ Print version and die.-          | ShowHelp       -- ^ Show help message and die.-          | GenerateHo     -- ^ Generate ho-          | GenerateHoGrin -- ^ Generate ho and grin-          | GenerateC      -- ^ Generate C file-          | GenerateExe    -- ^ Generate executable-          | KeepTmpFiles   -- ^ Keep ho grin C and generate executable-          | DependencyTree -- ^ show simple dependency tree-          | ShowHo String  -- ^ Show ho-file.-          | ListLibraries  -- ^ List libraries-            deriving(Eq)---data Opt = Opt {-    optMode        :: Mode,       -- ^ Mode of interaction-    optColumns     :: !Int,       -- ^ Width of terminal.-    optDebug       :: !Bool,      -- ^ Debugging.-    optDump        ::  [String],  -- ^ Dump options (raw).-    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).-    optHlPath      ::  [String],  -- ^ Path to look for libraries.-    optIncs        ::  [String],-    optDefs        ::  [String],-    optCC          ::  String,    -- ^ C compiler.-    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        ::  Maybe String,           -- ^ target architecture-    optOutName     ::  String,                 -- ^ Name of output file.-    optPrelude     :: !Bool,                   -- ^ No implicit Prelude.-    optIgnoreHo    :: !Bool,                   -- ^ Ignore ho-files.-    optNoWriteHo   :: !Bool,                   -- ^ Don't write ho-files.-    optNoAuto      :: !Bool,                   -- ^ Don't autoload packages-    optFollowDeps  :: !Bool,                   -- ^ Don't follow dependencies, all deps must be loaded from packages or specified on the command line.-    optVerbose     :: !Int,                    -- ^ Verbosity-    optStatLevel   :: !Int,                    -- ^ Level to print statistics-    optDumpSet     ::  S.Set FlagDump.Flag,    -- ^ Dump flags.-    optFOptsSet    ::  S.Set FlagOpts.Flag     -- ^ Flag options (-f\<opt\>).-  } -$(derive makeUpdate ''Opt)---opt = Opt {-    optMode        = GenerateExe,-    optColumns     = getColumns,-    optDebug       = False,-    optIncdirs     = initialIncludes,-    optHls         = [],-    optHlPath      = initialLibIncludes,-    optIncs        = [],-    optDefs        = [],-    optDump        = [],-    optStale       = [],-    optFOpts       = ["default","lint"],-    optCCargs      = [],-    optHoDir       = Nothing,-    optHoCache     = Nothing,-    optCC          = "gcc",-    optArgs        = [],-    optIgnoreHo    = False,-    optNoWriteHo   = False,-    optKeepGoing   = False,-    optMainFunc    = Nothing,-    optArch        = Nothing,-    optOutName     = "hs.out",-    optPrelude     = True,-    optFollowDeps  = True,-    optVerbose     = 0,-    optStatLevel   = 1,-    optNoAuto      = False,-    optDumpSet     = S.empty,-    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 []    ["help"]      (NoArg  (optMode_s ShowHelp))         "print help information and exit"-    , Option ['v'] ["verbose"]   (NoArg  (optVerbose_u (+1)))          "chatty output on stderr"-    , Option ['z'] []            (NoArg  (optStatLevel_u (+1)))        "Increase verbosity of statistics"-    , Option ['d'] []            (ReqArg (\d -> optDump_u (d:)) "[no-]flag")  "dump specified data during compilation"-    , Option ['f'] []            (ReqArg (\d -> optFOpts_u (d:)) "[no-]flag") "set or clear compilation options"-    , Option ['o'] ["output"]    (ReqArg (optOutName_s) "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 (\d -> optDefs_u (d:)) "NAME=VALUE") "add new definitions to set in preprocessor"-    , Option []    ["optc"]      (ReqArg (optCCargs_u . idu) "option") "extra options to pass to c compiler"-    , Option []    ["progc"]     (ReqArg (\d -> optCC_s d) "gcc")      "c compiler to use"-    , Option ['N'] ["noprelude"] (NoArg  (optPrelude_s False))         "no implicit prelude"-    , Option ['C'] []            (NoArg  (optMode_s GenerateHo))       "Typecheck and compile ho."-    , Option ['G'] []            (NoArg  (optMode_s GenerateHoGrin))   "Typecheck, compile ho and grin."-    , Option ['c'] []            (NoArg  (optMode_s GenerateC))        "generate C but don't link"-    , Option [] ["keep-tmp-files"] (NoArg (optMode_s KeepTmpFiles))    "keep all temporary files"-    , Option ['k'] ["keepgoing"] (NoArg  (optKeepGoing_s True))        "keep going on errors."-    , 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_s . Just ) "arch")            "target architecture."-    , Option []    ["entry"]     (ReqArg (optMainFunc_s . Just . (,) True)  "<expr>")  "main entry point, showable expression."-    , Option []    ["debug"]     (NoArg  (optDebug_s True))            "debugging"-    , 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 (\d -> optHls_u (++ [d])) "file.hl") "Load given haskell library .hl file"-    , Option ['L'] []            (ReqArg (optHlPath_u . idu) "path")   "Look for haskell libraries in the given directory."-    , Option []    ["build-hl"]  (ReqArg (optMode_s . BuildHl) "file.cabal") "Build hakell library from given library description file"-    , Option []    ["ignore-ho"]   (NoArg  (optIgnoreHo_s True))       "Ignore existing haskell object files"-    , Option []    ["nowrite-ho"]  (NoArg  (optNoWriteHo_s True))      "Do not write new haskell object files"-    , Option []    ["no-ho"]       (NoArg  (optNoWriteHo_s True . optIgnoreHo_s True)) "same as --ignore-ho and --nowrite-ho"-    , Option []    ["ho-cache"]    (ReqArg (optHoCache_s . Just ) "HOCACHEDIR")    "Use a global ho cache located at the 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 a ho file is present"-    , Option []    ["dependency"]  (NoArg  (optMode_s DependencyTree))  "Follow import dependencies only then quit"-    , Option []    ["no-follow-deps"] (NoArg  (optFollowDeps_s False)) "Don't follow depencies not listed on command line."-    , Option []    ["list-libraries"] (NoArg  (optMode_s ListLibraries)) "List of installed libraries."-    ]---- | 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 }-        (_,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 }-        (_,xs) -> fail ("Unrecognized flag passed to '-f': "-                        ++ unwords xs ++ "\nValid flags:\n\n" ++ FlagOpts.helpMsg)--getArguments = do-    x <- lookupEnv "LHCOPTS"-    let eas = maybe [] words x-    as <- System.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))--{-# NOINLINE processOptions #-}--- | Parse commandline options.-processOptions :: IO Opt-processOptions = do-    argv <- getArguments-    let header = "Usage: lhc [OPTION...] Main.hs"-    let mkoptlist d os = "valid " ++ d ++ " arguments: 'help' for more info\n    " ++ intercalate "\n    " (map (intercalate ", ") $ pfill 100 ((2 +) . length) os) ++ "\n"-    let trailer = "\n" ++ mkoptlist "-d" FlagDump.helpFlags ++ "\n" ++ mkoptlist "-f" FlagOpts.helpFlags-    let (o,ns,rc) = getOpt Permute theoptions argv-    when (rc /= []) $ putErrDie (concat rc ++ usageInfo header theoptions ++ trailer)-    o1 <- either putErrDie return $ postProcessFD (foldl (flip ($)) opt o)-    o2 <- either putErrDie return $ postProcessFO o1-    when (optMode o2 == ShowHelp) $ do-        putStrLn (usageInfo header theoptions ++ trailer)-        exitSuccess-    case optNoAuto o2 of-      True -> return (o2 { optArgs = ns })-      False-> return (o2 { optArgs = ns, optHls  = ("base":optHls o2) })---{-# NOINLINE fileOptions #-}-fileOptions :: Monad m => [String] -> m Opt-fileOptions 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")---- | 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 LHCPATH enviroment variable.-initialIncludes :: [String]-initialIncludes = unsafePerformIO $ do-    p <- lookupEnv "LHCPATH"-    let x = maybe "" id p-    return (".":(tokens (== ':') x))---- | Include directories taken from LHCLIBPATH enviroment variable.-initialLibIncludes :: [String]-initialLibIncludes = unsafePerformIO $ do-    ps <- lookupEnv "LHCLIBPATH"-    h <- lookupEnv "HOME"-    l <- getAppUserDataDirectory "lhc"-    let paths = h ++ ["/usr/local","/usr"]-        bases = ["/lib","/share","/.cabal/lib"]-        vers = ["/lhc-" ++ shortVersion, "/lhc"]-    return $ nub $ maybe [] (tokens (':' ==))  ps ++ (l ++ "/lhc-" ++ shortVersion):[ p ++ b ++ v | b <- bases, p <- paths, v <- vers ]---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---flagOpt :: OptionMonad m => FlagOpts.Flag -> m Bool-flagOpt flag = do-    opt <- getOptions-    return (flag `S.member` optFOptsSet opt)--getArgString = do-    name <- System.getProgName-    args <- getArguments-    return (simpleQuote (name:args),head $ lines versionString)
− src/PackedString.hs 
@@ -1,435 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}--------------------------------------------------------------------------------- |--- Module      :  Data.PackedString--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ An efficient implementation of strings.-------------------------------------------------------------------------------------- Original GHC implementation by Bryan O\'Sullivan,--- rewritten to use UArray by Simon Marlow.--- modified by John Meacham for use in ginsu--- arch-tag: 8ad19c9c-9511-48a1-b25a-f5f98a386b8c--module PackedString (-	-- * The @PackedString@ type-        PackedString(..),      -- abstract, instances: Eq, Ord, Show, Typeable--         -- * Converting to and from @PackedString@s-	packString,  -- :: String -> PackedString-	unpackPS,    -- :: PackedString -> String-        showsPS,-        -- toString,-        toUTF8,---        lengthPS,---        utfLengthPS,--	joinPS,      -- :: PackedString -> [PackedString] -> PackedString-	-- * List-like manipulation functions-	nilPS,       -- :: PackedString-	consPS,      -- :: Char -> PackedString -> PackedString-	nullPS,      -- :: PackedString -> Bool-	appendPS,    -- :: PackedString -> PackedString -> PackedString---        foldrPS,-        hashPS,-        filterPS,---        foldlPS,---        headPS,-	concatPS    -- :: [PackedString] -> PackedString----    ) where--import Data.Typeable-import Data.Char-import Data.Int-import Data.Binary-import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as BSUTF8-import Bits-import GHC.Exts-import Word-import Data.Monoid--instance Monoid PackedString where-    mempty = nilPS-    mappend x y = appendPS x y-    mconcat xs = concatPS xs---- -------------------------------------------------------------------------------- PackedString type declaration---- | A space-efficient representation of a 'String', which supports various--- efficient operations.  A 'PackedString' contains full Unicode 'Char's.-newtype PackedString = PS BS.ByteString-    deriving(Typeable,Binary,Eq,Ord)---instance Show PackedString where-    showsPrec p ps r = showsPrec p (unpackPS ps) r----- -------------------------------------------------------------------------------- Constructor functions---- | The 'nilPS' value is the empty string.-nilPS :: PackedString-nilPS = PS BS.empty---- | The 'consPS' function prepends the given character to the--- given string.-consPS :: Char -> PackedString -> PackedString-consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better---- | Convert a 'String' into a 'PackedString'-packString :: String -> PackedString-packString str = PS $ (BSUTF8.fromString str)----- -------------------------------------------------------------------------------- Destructor functions (taking PackedStrings apart)---unpackPS :: PackedString -> String-unpackPS (PS bs) = BSUTF8.toString bs---unpackPS (PS (UArray _ (I# e) ba)) = unpackFoldrUtf8# (ba) (e +# 1#) f [] where---    f ch r = C# ch : r--showsPS :: PackedString -> String -> String-showsPS ps = (unpackPS ps ++)---showsPS  (PS (UArray _ (I# e) ba)) xs = unpackFoldrUtf8# (ba) (e +# 1#) f xs where---    f ch r = C# ch : r---toUTF8 :: PackedString -> [Word8]-toUTF8 (PS ba) = BS.unpack ba----lengthPS :: PackedString -> Int---lengthPS (PS (UArray _ (I# e) ba)) =  unpackFoldlUtf8#  (\x _ -> x + 1) 0 ba (e +# 1#)----utfLengthPS :: PackedString -> Int---utfLengthPS (PS (UArray _ e _)) = e + 1----headPS :: PackedString -> Char---headPS ps = case unpackPS ps of---    (x:_) -> x---    [] -> error "headPS: empty PackedString"---- | The 'indexPS' function returns the character in the string at the given position.---indexPS :: PackedString -> Int -> Char---indexPS (PS ps) i = ps ! i---- | The 'headPS' function returns the first element of a 'PackedString' or throws an--- error if the string is empty.---headPS :: PackedString -> Char---headPS ps---  | nullPS ps = error "Data.PackedString.headPS: head []"---  | otherwise  = indexPS ps 0---- | The 'tailPS' function returns the tail of a 'PackedString' or throws an error--- if the string is empty.---tailPS :: PackedString -> PackedString---tailPS ps---  | len <= 0 = error "Data.PackedString.tailPS: tail []"---  | len == 1 = nilPS---  | otherwise  = substrPS ps 1 (len - 1)---  where---    len = lengthPS ps---- | The 'nullPS' function returns True iff the argument is null.-nullPS :: PackedString -> Bool-nullPS (PS ps) = BS.null ps---- | The 'appendPS' function appends the second string onto the first.-appendPS :: PackedString -> PackedString -> PackedString-appendPS (PS xs) (PS ys) = PS (BS.append xs ys)----- | The 'filterPS' function filters out the appropriate substring.-filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}-filterPS pred ps = packString (filter pred (unpackPS ps))---- | The 'foldlPS' function behaves like 'foldl' on 'PackedString's.--- note, this version is strict. (behaves like foldl' )---foldlPS :: (a -> Char -> a) -> a -> PackedString -> a---foldlPS f b (PS (UArray _ (I# e) ba)) = unpackFoldlUtf8# (\x y -> f x (C# y)) b ba (e +# 1#)---- | The 'foldrPS' function behaves like 'foldr' on 'PackedString's.---foldrPS :: (Char -> a -> a) -> a -> PackedString -> a---foldrPS f b (PS (UArray _ (I# e) ba)) = unpackFoldrUtf8# ba (e +# 1#) (\x y -> f (C# x)  y) b---foldrPS f v ps = foldr f v (unpackPS ps)--hashPS :: PackedString -> Int32-hashPS (PS arr) = f 5381 (BS.unpack arr) where-    f x [] = x-    f m (c:cs) = n `seq` f n cs where-        n = ((m `shiftL` 5) + m ) `xor` fromIntegral c-{---hashPS' :: PackedString -> Int32-hashPS' (PS (UArray 0 (I# e) ba)) = fromIntegral $ unpackFoldlUtf8# f 5381 ba (e +# 1#) where-    f m c = ((m `shiftL` 5) + m ) `xor` I# (ord# c)--hashPS :: PackedString -> Word-hashPS (PS (UArray 0 (I# e) ba)) =  W# (f (unsafeCoerce# 5381#) 0#) where-    f m c-        | c >=# (e +# 1#) = m-        | otherwise = f (((m `uncheckedShiftL#` 5#) `plusWord#` m ) `xor#`  (((indexWord8Array# ba c)))) (c +# 1#)--}------ | The 'takePS' function takes the first @n@ characters of a 'PackedString'.---takePS :: Int -> PackedString -> PackedString---takePS n ps = substrPS ps 0 (n-1)---- | The 'dropPS' function drops the first @n@ characters of a 'PackedString'.---dropPS	:: Int -> PackedString -> PackedString---dropPS n ps = substrPS ps n (lengthPS ps - 1)---- | The 'splitWithPS' function splits a 'PackedString' at a given index.---splitAtPS :: Int -> PackedString -> (PackedString, PackedString)---splitAtPS  n ps  = (takePS n ps, dropPS n ps)---- | The 'takeWhilePS' function is analogous to the 'takeWhile' function.---takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString---takeWhilePS pred ps = packString (takeWhile pred (unpackPS ps))---- | The 'dropWhilePS' function is analogous to the 'dropWhile' function.---dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString---dropWhilePS pred ps = packString (dropWhile pred (unpackPS ps))---- | The 'elemPS' function returns True iff the given element is in the string.---elemPS :: Char -> PackedString -> Bool---elemPS c ps = c `elem` unpackPS ps---- | The 'spanPS' function returns a pair containing the result of--- running both 'takeWhilePS' and 'dropWhilePS'.---spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)---spanPS  p ps = (takeWhilePS p ps, dropWhilePS p ps)---- | The 'breakPS' function breaks a string at the first position which--- satisfies the predicate.---breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)---breakPS p ps = spanPS (not . p) ps---- | The 'linesPS' function splits the input on line-breaks.---linesPS :: PackedString -> [PackedString]---linesPS ps = splitPS '\n' ps---- | The 'unlinesPS' function concatenates the input list after--- interspersing newlines.---unlinesPS :: [PackedString] -> PackedString---unlinesPS = joinPS (packString "\n")---- | The 'wordsPS' function is analogous to the 'words' function.---wordsPS :: PackedString -> [PackedString]---wordsPS ps = filter (not.nullPS) (splitWithPS isSpace ps)---- | The 'unwordsPS' function is analogous to the 'unwords' function.---unwordsPS :: [PackedString] -> PackedString---unwordsPS = joinPS (packString " ")---- | The 'reversePS' function reverses the string.---reversePS :: PackedString -> PackedString---reversePS ps = packString (reverse (unpackPS ps))---- | The 'concatPS' function concatenates a list of 'PackedString's.-concatPS :: [PackedString] -> PackedString-concatPS pss = packString (concat (map unpackPS pss))------------------------------------------------------------------ | The 'joinPS' function takes a 'PackedString' and a list of 'PackedString's--- and concatenates the list after interspersing the first argument between--- each element of the list.-joinPS :: PackedString -> [PackedString] -> PackedString-joinPS filler pss = concatPS (splice pss)- where-  splice []  = []-  splice [x] = [x]-  splice (x:y:xs) = x:filler:splice (y:xs)---- ToDo: the obvious generalisation-{--  Some properties that hold:--  * splitPS x ls = ls'-      where False = any (map (x `elemPS`) ls')--  * joinPS (packString [x]) (splitPS x ls) = ls--}---- | The 'splitPS' function splits the input string on each occurance of the given 'Char'.---splitPS :: Char -> PackedString -> [PackedString]---splitPS c = splitWithPS (== c)---- | The 'splitWithPS' function takes a character predicate and splits the input string--- at each character which satisfies the predicate.---splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]---splitWithPS pred (PS ps) =--- splitify 0--- where---  len = lengthPS (PS ps)----  splitify n---   | n >= len = []---   | otherwise =---      let---       break_pt = first_pos_that_satisfies pred ps len n---      in---      if break_pt == n then -- immediate match, empty substring---         nilPS---	 : splitify (break_pt + 1)---      else---         substrPS (PS ps) n (break_pt - 1) -- leave out the matching character---         : splitify (break_pt + 1)------first_pos_that_satisfies pred ps len n =---   case [ m | m <- [n..len-1], pred (ps ! m) ] of---	[]    -> len---	(m:_) -> m---- -------------------------------------------------------------------------------- Local utility functions---- The definition of @_substrPS@ is essentially:--- @take (end - begin + 1) (drop begin str)@.---- | The 'substrPS' function takes a 'PackedString' and two indices--- and returns the substring of the input string between (and including)--- these indices.---substrPS :: PackedString -> Int -> Int -> PackedString---substrPS (PS ps) begin end = packString [ ps ! i | i <- [begin..end] ]---- -------------------------------------------------------------------------------- hPutPS---- | Outputs a 'PackedString' to the specified 'Handle'.------ NOTE: the representation of the 'PackedString' in the file is assumed to--- be in the ISO-8859-1 encoding.  In other words, only the least signficant--- byte is taken from each character in the 'PackedString'.---hPutPS :: Handle -> PackedString -> IO ()---hPutPS h (PS ps) = do---  let l = lengthPS (PS ps)---  arr <- newArray_ (0, l-1)---  sequence_ [ writeArray arr i (fromIntegral (ord (ps ! i))) | i <- [0..l-1] ]---  hPutArray h arr l---- -------------------------------------------------------------------------------- hGetPS---- | Read a 'PackedString' directly from the specified 'Handle'.--- This is far more efficient than reading the characters into a 'String'--- and then using 'packString'.------ NOTE: as with 'hPutPS', the string representation in the file is--- assumed to be ISO-8859-1.---hGetPS :: Handle -> Int -> IO PackedString---hGetPS h i = do---  arr <- newArray_ (0, i-1)---  l <- hGetArray h arr i---  chars <- mapM (\i -> readArray arr i >>= return.chr.fromIntegral) [0..l-1]---  return (packString chars)---utfCount :: String -> Int#-utfCount cs = uc 0# cs where-    uc n []  = n-    uc n (x:xs)-        | ord x <= 0x7f = uc (n +# 1#) xs-        | ord x <= 0x7ff = uc (n +# 2#) xs-        | ord x <= 0xffff = uc (n +# 3#) xs-        | ord x <= 0x1fffff = uc (n +# 4#) xs-        | ord x <= 0x3ffffff = uc (n +# 5#) xs-        | ord x <= 0x7fffffff = uc (n +# 6#) xs-        | otherwise = error "invalid string"----{-# INLINE unpackFoldrUtf8# #-}-unpackFoldrUtf8# :: ByteArray# -> Int# -> (Char# -> b -> b) -> b -> b-unpackFoldrUtf8# addr count f e = unpack 0# where-    unpack nh-      | nh ==# count  = e-      | ch `leChar#` '\x7F'# =  ch `f` unpack (nh +# 1#)-      | ch `leChar#` '\xDF'# =-           (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--{-# INLINE unpackFoldlUtf8# #-}-unpackFoldlUtf8# ::  (a -> Char# -> a) -> a -> ByteArray# -> Int# -> a-unpackFoldlUtf8# f e addr count = unpack 0# e where-    unpack nh e-      | nh ==# count  = e-      | ch `leChar#` '\x7F'# = let n = (f e ch) in n `seq` unpack (nh +# 1#) n-      | ch `leChar#` '\xDF'# =-           let n = f e (chr# (((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6#) +#-                     (ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#))) in n `seq` unpack (nh +# 2#) n-      | ch `leChar#` '\xEF'# =-         let n = f e (chr# (((ord# ch                        -# 0xE0#) `uncheckedIShiftL#` 12#) +#-                    ((ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#-                     (ord# (indexCharArray# addr (nh +# 2#)) -# 0x80#))) in n `seq` unpack (nh +# 3#) n-      | otherwise            =-         let n = f e (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#))) in n `seq` unpack (nh +# 4#) n-      where-	ch = indexCharArray# addr nh---{---less efficient non-ghc versions---- | Convert a 'PackedString' into a 'String'---unpackPS :: PackedString -> String---unpackPS (PS ps) = fromUTF (elems ps)--- | Convert UTF-8 to Unicode.--fromUTF :: [Word8] -> String-fromUTF xs = fromUTF' (map fromIntegral xs) where-    fromUTF' [] = []-    fromUTF' (all@(x:xs))-	| x<=0x7F = (chr (x)):fromUTF' xs-	| x<=0xBF = err-	| x<=0xDF = twoBytes all-	| x<=0xEF = threeBytes all-	| otherwise   = err-    twoBytes (x1:x2:xs) = chr  ((((x1 .&. 0x1F) `shift` 6) .|.-			       (x2 .&. 0x3F))):fromUTF' xs-    twoBytes _ = error "fromUTF: illegal two byte sequence"--    threeBytes (x1:x2:x3:xs) = chr ((((x1 .&. 0x0F) `shift` 12) .|.-				    ((x2 .&. 0x3F) `shift` 6) .|.-				    (x3 .&. 0x3F))):fromUTF' xs-    threeBytes _ = error "fromUTF: illegal three byte sequence"--    err = error "fromUTF: illegal UTF-8 character"---}
− src/PrimitiveOperators.hs 
@@ -1,1186 +0,0 @@--{- This file is generated -}-module PrimitiveOperators(-    primitiveInsts,-    constantMethods,-    create_uintegralCast_toInt,-    create_uintegralCast_fromInt,-    theMethods,-    allCTypes-    ) where--import Data.Monoid--import C.Arch-import C.Prims-import E.E-import E.TypeCheck()-import E.Values-import FrontEnd.Tc.Type-import Name.Name-import Name.Prim-import Name.VConsts-import Support.CanType-import qualified Cmm.Op as Op-import Name.Id--nameToOpTy n = do RawType <- return $ nameType n; Op.readTy (show n)--tPtr t = ELit (litCons { litName = tc_Ptr-                       , litArgs = [t]-                       , litType = eStar-                       , litAliasFor = Just (ELam tvr { tvrIdent = anonymous 2-                                                      , tvrType = eStar}-                                             (ELit litCons { litName = tc_Addr, litType = eStar })) })--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 (anonymous 4) t1-    tvrb =  tVr (anonymous 6) t2-    cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else-        eStrictLet  tvrb (EPrim (APrim (Op (Op.ConvOp conv n1') n2') mempty) [EVar tvra] t2)  (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t }))--create_integralCast_toInt c1 t1 e = create_integralCast Op.I2I c1 t1 dc_Int tIntzh e tInt-create_integralCast_toInteger c1 t1 e = create_integralCast Op.Sx c1 t1 dc_Integer tIntegerzh e tInteger-create_integralCast_fromInt c2 t2 e t = create_integralCast Op.I2I dc_Int tIntzh c2 t2 e t-create_integralCast_fromInteger c2 t2 e t = create_integralCast Op.Lobits dc_Integer tIntegerzh c2 t2 e t--create_uintegralCast_toInt c1 t1 e = create_integralCast Op.U2U c1 t1 dc_Int tIntzh e tInt-create_uintegralCast_toInteger c1 t1 e = create_integralCast Op.Zx c1 t1 dc_Integer tIntegerzh e tInteger-create_uintegralCast_fromInt c2 t2 e t = create_integralCast Op.U2U dc_Int tIntzh c2 t2 e t-create_uintegralCast_fromInteger c2 t2 e t = create_integralCast Op.Lobits dc_Integer tIntegerzh c2 t2 e t--create_fintegralCast_fromInt c2 t2 e t = create_integralCast Op.I2F dc_Int tIntzh c2 t2 e t-create_fintegralCast_fromInteger c2 t2 e t = create_integralCast Op.I2F dc_Integer tIntegerzh c2 t2 e t---toClassName x = parseName ClassName x--toInstName x = toName Val ("Instance@",'i':x)--unbox' e cn tvr wtd = eCase e [Alt (litCons { litName = cn, litArgs = [tvr], litType = te }) wtd] Unknown where-    te = getType e--binOp op ca cb cr = APrim (Op (Op.BinOp op ca cb) cr) mempty--oper_aa op ct' e = EPrim (APrim (Op (Op.UnOp op ct) ct) mempty) [e] (rawType ct') where-    ct = stringToOpTy ct'-oper_aaB op ct' a b = EPrim (binOp op ct ct ot_int) [a,b] tBoolzh where-    ct = stringToOpTy ct'-oper_aaa op ct' a b = EPrim (binOp op ct ct ct) [a,b] (rawType ct') where-    ct = stringToOpTy ct'-oper_aIa op ct' a b = EPrim (binOp op ct ot_int ct) [a,b] (rawType ct') where-    ct = stringToOpTy ct'----zeroI =  LitInt 0 intt--ot_int = stringToOpTy "bits32"--op_aIa op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') dc_Int tvrb wtd))) where-    tvra' = tVr (anonymous 2) t-    tvrb' = tVr (anonymous 4) tInt-    tvra = tVr (anonymous 6) st-    tvrb = tVr (anonymous 8) intt-    tvrc = tVr (anonymous 10) st-    st = rawType ct-    intt = rawType "bits32"-    wtd = eStrictLet tvrc (oper_aIa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc))-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t })-op_aaa op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where-    tvra' = tVr (anonymous 2) t-    tvrb' = tVr (anonymous 4) t-    tvra = tVr (anonymous 6) st-    tvrb = tVr (anonymous 8) st-    tvrc = tVr (anonymous 10) st-    st = rawType ct-    wtd = eStrictLet tvrc (oper_aaa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc))-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t })-op_aa op ct cn t = ELam tvra' (unbox' (EVar tvra') cn tvra wtd) where-    tvra' = tVr (anonymous 2) t-    tvra = tVr (anonymous 6) st-    tvrc = tVr (anonymous 10) st-    st = rawType ct-    wtd = eStrictLet tvrc (oper_aa op ct (EVar tvra)) (rebox (EVar tvrc))-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t })---op_aaI op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where---    tvra' = tVr 2 t---    tvrb' = tVr 4 t---    tvra = tVr 6 st---    tvrb = tVr 8 st---    tvrc = tVr 10 intt---    st = rawType ct---    wtd = eStrictLet tvrc (oper_aaI op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc))---    rebox x = ELit (litCons { litName = dc_Int, litArgs = [x], litType = t })--op_aaB op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where-    tvra' = tVr (anonymous 2) t-    tvrb' = tVr (anonymous 4) t-    tvra = tVr (anonymous 6) st-    tvrb = tVr (anonymous 8) st-    tvrc = tVr (anonymous 10) tBoolzh-    st = rawType ct-    wtd = eStrictLet tvrc (oper_aaB op ct (EVar tvra) (EVar tvrb)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar tvrc], litType = tBool }))  -- (caseof (EVar tvrc))---    caseof x = eCase x [Alt zeroI vFalse]  vTrue--build_abs ct cn v = unbox' v cn tvra (eCase (oper_aaB Op.Lt ct (EVar tvra) zero)  [Alt lFalsezh (rebox $ EVar tvra), Alt lTruezh fs] Unknown) where-    te = getType v-    tvra = tVr (anonymous 2) st-    tvrb = tVr (anonymous 4) st-    zero = ELit $ LitInt 0 st-    st = rawType ct-    fs = eStrictLet tvrb (oper_aa Op.Neg ct (EVar tvra)) (rebox (EVar tvrb))-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })--build_uabs ct cn v = v--build_fabs ct cn v = unbox' v cn tvra (rebox (oper_aa Op.FAbs ct (EVar tvra))) where-    te = getType v-    tvra = tVr (anonymous 2) st-    st = rawType ct-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })--build_usignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (rebox (ELit one))) where-    tvra = tVr (anonymous 2) st-    te = getType v-    st = rawType ct-    zero :: Lit a E-    zero = LitInt 0 st-    one = LitInt 1 st-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })--build_signum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.Lt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where-    tvra = tVr (anonymous 2) st-    te = getType v-    st = rawType ct-    zero :: Lit a E-    zero = LitInt 0 st-    one = ELit $ LitInt 1 st-    negativeOne = ELit $ LitInt (-1) st-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })---build_fsignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.FLt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where-    tvra = tVr (anonymous 2) st-    te = getType v-    st = rawType ct-    zero :: Lit a E-    zero = LitInt 0 st-    one = ELit $ LitInt 1 st-    negativeOne = ELit $ LitInt (-1) st-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })---buildPeek cn t p = ELam tvr $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest)  where-    tvr = (tVr (anonymous 2) (tPtr t))-    tvr' = tVr (anonymous 4) (rawType "bits<ptr>")-    tvrWorld2 = tVr (anonymous 258) tWorld__-    tvrWorld = tVr (anonymous 256) tWorld__-    rtVar = tVr (anonymous 260) (rawType p)-    rtVar' = tVr (anonymous 262) t-    rest = eCaseTup' (EPrim (APrim (Peek (stringToOpTy p)) mempty) [EVar tvrWorld, EVar tvr'] (ltTuple' [tWorld__,rawType p])) [tvrWorld2,rtVar] (eLet rtVar' (ELit $ litCons { litName = cn, litArgs = [EVar rtVar], litType = t }) $ eJustIO (EVar tvrWorld2) (EVar rtVar') )---buildPoke cn t p = ELam ptr_tvr $ ELam v_tvr $ createIO_ $ (\tw -> unbox' (EVar ptr_tvr) dc_Addr ptr_tvr' $ unbox' (EVar v_tvr) cn v_tvr' $ EPrim (APrim (Poke (stringToOpTy p)) mempty) [EVar tw, EVar ptr_tvr', EVar v_tvr'] tWorld__) where-    ptr_tvr =  (tVr (anonymous 2) (tPtr t))-    v_tvr = tVr (anonymous 4) t-    ptr_tvr' =  (tVr (anonymous 6) (rawType "bits<ptr>"))-    v_tvr' = tVr (anonymous 8) (rawType p)--toIO :: E -> E -> E-toIO t x = x--{--createIO t pv = toIO t (ELam tvrWorld $  eCaseTup  (pv tvrWorld) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))) where-    tvrWorld2 = tVr 258 tWorld__-    tvrWorld = tVr 256 tWorld__-    rtVar = tVr 260 t--}-createIO_ pv = toIO tUnit (ELam tvrWorld $  eStrictLet tvrWorld2 (pv tvrWorld)  (eJustIO (EVar tvrWorld2) vUnit)) where-    tvrWorld2 = tVr (anonymous 258) tWorld__-    tvrWorld = tVr (anonymous 256) tWorld__---prim_number cn v t et = ELit litCons { litName = cn, litArgs = [ELit (LitInt v t)], litType = et }--prim_minbound, prim_maxbound, prim_uminbound, prim_umaxbound :: Name -> E -> ExtType ->  E-prim_uminbound dc dt s = prim_number dc 0 (rawType s) dt-prim_umaxbound = prim_bound PrimUMaxBound-prim_maxbound = prim_bound PrimMaxBound-prim_minbound = prim_bound PrimMinBound--prim_bound pt dc dt s = (ELit (litCons { litName = dc, litArgs = [rp], litType = dt })) where-    rt = rawType s-    Just at = Op.readTy s-    rp | Just n <- primStaticTypeInfo at pt = (ELit (LitInt (fromInteger n) rt))-       | otherwise = EPrim (APrim (PrimTypeInfo { primArgTy = at, primRetTy = at, primTypeInfo = pt }) mempty) [] rt--prim_sizeof s = (ELit (litCons { litName = dc_Int, litArgs = [rp], litType = tInt })) where-    Just at = Op.readTy s-    rp | Just n <- primStaticTypeInfo at PrimSizeOf = (ELit (LitInt (fromInteger n) tIntzh))-       | otherwise = EPrim (APrim (PrimTypeInfo { primArgTy = stringToOpTy s, primRetTy = ot_int, primTypeInfo = PrimSizeOf }) mempty) [] tIntzh---v2_Int = tVr (anonymous 2) tInt-v2_Integer = tVr (anonymous 2) tInteger-v2 t = tVr (anonymous 2) t--v0 t = tVr emptyId t--{-# NOINLINE constantMethods #-}-{-# NOINLINE primitiveInsts #-}-{-# NOINLINE allCTypes #-}---primitiveInsts = [-   [] :=> IsIn n_Lhc_Enum_Bounded tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Lhc_Num_Num tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Data_Bits_Bits tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Lhc_Prim_Int-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Lhc_Num_Num tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Data_Bits_Bits tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Lhc_Basics_Integer-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Int_Int8-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Int_Int8-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Int_Int8-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Int_Int8-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Int_Int8-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Int_Int8-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Int_Int8-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Int_Int16-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Int_Int16-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Int_Int16-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Int_Int16-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Int_Int16-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Int_Int16-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Int_Int16-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Int_Int32-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Int_Int32-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Int_Int32-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Int_Int32-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Int_Int32-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Int_Int32-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Int_Int32-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Int_Int64-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Int_Int64-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Int_Int64-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Int_Int64-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Int_Int64-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Int_Int64-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Int_Int64-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Int_IntMax-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Int_IntMax-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Int_IntMax-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Int_IntMax-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Int_IntMax-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Int_IntMax-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Int_IntMax-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Int_IntPtr-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_Word-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_Word-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_Word-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_Word-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_Word-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_Word-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_Word-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_Word8-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_Word8-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_Word8-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_Word8-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_Word8-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_Word8-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_Word8-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_Word16-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_Word16-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_Word16-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_Word16-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_Word16-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_Word16-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_Word16-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_Word32-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_Word32-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_Word32-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_Word32-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_Word32-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_Word32-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_Word32-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_Word64-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_Word64-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_Word64-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_Word64-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_Word64-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_Word64-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_Word64-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_WordMax-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_WordMax-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_WordMax-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_WordMax-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_WordMax-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_WordMax-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_WordMax-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Lhc_Num_Num tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Data_Bits_Bits tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Data_Word_WordPtr-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CChar-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CShort-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CInt-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CUInt-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CSize-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CWchar-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Data_Bits_Bits tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Lhc_Num_Integral tc_Foreign_C_Types_CWint-  ,[] :=> IsIn n_Lhc_Enum_Bounded tc_Foreign_C_Types_CTime-  ,[] :=> IsIn n_Foreign_Storable_Storable tc_Foreign_C_Types_CTime-  ,[] :=> IsIn n_Lhc_Order_Eq tc_Foreign_C_Types_CTime-  ,[] :=> IsIn n_Lhc_Order_Ord tc_Foreign_C_Types_CTime-  ,[] :=> IsIn n_Lhc_Num_Num tc_Foreign_C_Types_CTime ]--constantMethods = [-   (n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Lhc.Prim.Int", ELam (v0 t_Lhc_Prim_Int) $ prim_sizeof "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Lhc.Prim.Int", buildPoke dc_Int t_Lhc_Prim_Int "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Lhc.Prim.Int", buildPeek dc_Int t_Lhc_Prim_Int "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Lhc.Prim.Int", prim_maxbound dc_Int t_Lhc_Prim_Int "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Lhc.Prim.Int", prim_minbound dc_Int t_Lhc_Prim_Int "bits32")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Lhc.Prim.Int", ELam v2_Int (EVar v2_Int))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Lhc.Prim.Int", ELam v2_Int (EVar v2_Int))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Lhc.Prim.Int", ELam v2_Integer (create_integralCast_fromInteger dc_Int r_bits32 (EVar v2_Integer) t_Lhc_Prim_Int))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Lhc.Prim.Int", ELam (v2 t_Lhc_Prim_Int) (create_integralCast_toInteger dc_Int r_bits32 (EVar (v2 t_Lhc_Prim_Int))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Lhc.Prim.Int", ELam (v2 t_Lhc_Prim_Int) (build_abs "bits32" dc_Int (EVar (v2 t_Lhc_Prim_Int))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Lhc.Prim.Int", ELam (v2 t_Lhc_Prim_Int) (build_signum "bits32" dc_Int (EVar (v2 t_Lhc_Prim_Int)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Lhc.Prim.Int", op_aaB  Op.Eq "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Lhc.Prim.Int", op_aaB  Op.Gte "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Lhc.Prim.Int", op_aaB  Op.Lte "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Lhc.Prim.Int", op_aaB  Op.Gt "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Lhc.Prim.Int", op_aaB  Op.Lt "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Lhc.Prim.Int", op_aaa  Op.Add "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Lhc.Prim.Int", op_aaa  Op.Sub "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Lhc.Prim.Int", op_aaa  Op.Mul "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Lhc.Prim.Int", op_aa  Op.Neg "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Lhc.Prim.Int", op_aaa  Op.And "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Lhc.Prim.Int", op_aaa  Op.Or "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Lhc.Prim.Int", op_aaa  Op.Xor "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Lhc.Prim.Int", op_aa  Op.Com "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Lhc.Prim.Int", op_aaa  Op.Div "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Lhc.Prim.Int", op_aaa  Op.Mod "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Lhc.Prim.Int", op_aaa  Op.Div "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Lhc.Prim.Int", op_aaa  Op.Mod "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Lhc.Prim.Int", op_aIa  Op.Shl "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Lhc.Prim.Int", op_aIa  Op.Shra "bits32" dc_Int t_Lhc_Prim_Int)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Lhc.Basics.Integer", ELam (v0 t_Lhc_Basics_Integer) $ prim_sizeof "bits<max>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Lhc.Basics.Integer", buildPoke dc_Integer t_Lhc_Basics_Integer "bits<max>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Lhc.Basics.Integer", buildPeek dc_Integer t_Lhc_Basics_Integer "bits<max>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Lhc.Basics.Integer", prim_maxbound dc_Integer t_Lhc_Basics_Integer "bits<max>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Lhc.Basics.Integer", prim_minbound dc_Integer t_Lhc_Basics_Integer "bits<max>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Lhc.Basics.Integer", ELam v2_Int (create_integralCast_fromInt dc_Integer r_bits_max_ (EVar v2_Int) t_Lhc_Basics_Integer))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Lhc.Basics.Integer", ELam (v2 t_Lhc_Basics_Integer) (create_integralCast_toInt dc_Integer r_bits_max_ (EVar (v2 t_Lhc_Basics_Integer))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Lhc.Basics.Integer", ELam v2_Integer (EVar v2_Integer))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Lhc.Basics.Integer", ELam v2_Integer (EVar v2_Integer))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Lhc.Basics.Integer", ELam (v2 t_Lhc_Basics_Integer) (build_abs "bits<max>" dc_Integer (EVar (v2 t_Lhc_Basics_Integer))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Lhc.Basics.Integer", ELam (v2 t_Lhc_Basics_Integer) (build_signum "bits<max>" dc_Integer (EVar (v2 t_Lhc_Basics_Integer)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Lhc.Basics.Integer", op_aaB  Op.Eq "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Lhc.Basics.Integer", op_aaB  Op.Gte "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Lhc.Basics.Integer", op_aaB  Op.Lte "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Lhc.Basics.Integer", op_aaB  Op.Gt "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Lhc.Basics.Integer", op_aaB  Op.Lt "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Lhc.Basics.Integer", op_aaa  Op.Add "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Lhc.Basics.Integer", op_aaa  Op.Sub "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Lhc.Basics.Integer", op_aaa  Op.Mul "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Lhc.Basics.Integer", op_aa  Op.Neg "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Lhc.Basics.Integer", op_aaa  Op.And "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Lhc.Basics.Integer", op_aaa  Op.Or "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Lhc.Basics.Integer", op_aaa  Op.Xor "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Lhc.Basics.Integer", op_aa  Op.Com "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Lhc.Basics.Integer", op_aaa  Op.Div "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Lhc.Basics.Integer", op_aaa  Op.Mod "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Lhc.Basics.Integer", op_aaa  Op.Div "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Lhc.Basics.Integer", op_aaa  Op.Mod "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Lhc.Basics.Integer", op_aIa  Op.Shl "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Lhc.Basics.Integer", op_aIa  Op.Shra "bits<max>" dc_Integer t_Lhc_Basics_Integer)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Int.Int8", ELam (v0 t_Data_Int_Int8) $ prim_sizeof "bits8")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Int.Int8", buildPoke dc_Int8 t_Data_Int_Int8 "bits8")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Int.Int8", buildPeek dc_Int8 t_Data_Int_Int8 "bits8")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Int.Int8", prim_maxbound dc_Int8 t_Data_Int_Int8 "bits8")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Int.Int8", prim_minbound dc_Int8 t_Data_Int_Int8 "bits8")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Int.Int8", ELam v2_Int (create_integralCast_fromInt dc_Int8 r_bits8 (EVar v2_Int) t_Data_Int_Int8))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Int.Int8", ELam (v2 t_Data_Int_Int8) (create_integralCast_toInt dc_Int8 r_bits8 (EVar (v2 t_Data_Int_Int8))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Int.Int8", ELam v2_Integer (create_integralCast_fromInteger dc_Int8 r_bits8 (EVar v2_Integer) t_Data_Int_Int8))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Int.Int8", ELam (v2 t_Data_Int_Int8) (create_integralCast_toInteger dc_Int8 r_bits8 (EVar (v2 t_Data_Int_Int8))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Int.Int8", ELam (v2 t_Data_Int_Int8) (build_abs "bits8" dc_Int8 (EVar (v2 t_Data_Int_Int8))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Int.Int8", ELam (v2 t_Data_Int_Int8) (build_signum "bits8" dc_Int8 (EVar (v2 t_Data_Int_Int8)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Int.Int8", op_aaB  Op.Eq "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Int.Int8", op_aaB  Op.Gte "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Int.Int8", op_aaB  Op.Lte "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Int.Int8", op_aaB  Op.Gt "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Int.Int8", op_aaB  Op.Lt "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Int.Int8", op_aaa  Op.Add "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Int.Int8", op_aaa  Op.Sub "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Int.Int8", op_aaa  Op.Mul "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Int.Int8", op_aa  Op.Neg "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Int.Int8", op_aaa  Op.And "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Int.Int8", op_aaa  Op.Or "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Int.Int8", op_aaa  Op.Xor "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Int.Int8", op_aa  Op.Com "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Int.Int8", op_aaa  Op.Div "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Int.Int8", op_aaa  Op.Mod "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Int.Int8", op_aaa  Op.Div "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Int.Int8", op_aaa  Op.Mod "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Int.Int8", op_aIa  Op.Shl "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Int.Int8", op_aIa  Op.Shra "bits8" dc_Int8 t_Data_Int_Int8)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Int.Int16", ELam (v0 t_Data_Int_Int16) $ prim_sizeof "bits16")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Int.Int16", buildPoke dc_Int16 t_Data_Int_Int16 "bits16")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Int.Int16", buildPeek dc_Int16 t_Data_Int_Int16 "bits16")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Int.Int16", prim_maxbound dc_Int16 t_Data_Int_Int16 "bits16")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Int.Int16", prim_minbound dc_Int16 t_Data_Int_Int16 "bits16")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Int.Int16", ELam v2_Int (create_integralCast_fromInt dc_Int16 r_bits16 (EVar v2_Int) t_Data_Int_Int16))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Int.Int16", ELam (v2 t_Data_Int_Int16) (create_integralCast_toInt dc_Int16 r_bits16 (EVar (v2 t_Data_Int_Int16))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Int.Int16", ELam v2_Integer (create_integralCast_fromInteger dc_Int16 r_bits16 (EVar v2_Integer) t_Data_Int_Int16))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Int.Int16", ELam (v2 t_Data_Int_Int16) (create_integralCast_toInteger dc_Int16 r_bits16 (EVar (v2 t_Data_Int_Int16))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Int.Int16", ELam (v2 t_Data_Int_Int16) (build_abs "bits16" dc_Int16 (EVar (v2 t_Data_Int_Int16))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Int.Int16", ELam (v2 t_Data_Int_Int16) (build_signum "bits16" dc_Int16 (EVar (v2 t_Data_Int_Int16)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Int.Int16", op_aaB  Op.Eq "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Int.Int16", op_aaB  Op.Gte "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Int.Int16", op_aaB  Op.Lte "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Int.Int16", op_aaB  Op.Gt "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Int.Int16", op_aaB  Op.Lt "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Int.Int16", op_aaa  Op.Add "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Int.Int16", op_aaa  Op.Sub "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Int.Int16", op_aaa  Op.Mul "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Int.Int16", op_aa  Op.Neg "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Int.Int16", op_aaa  Op.And "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Int.Int16", op_aaa  Op.Or "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Int.Int16", op_aaa  Op.Xor "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Int.Int16", op_aa  Op.Com "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Int.Int16", op_aaa  Op.Div "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Int.Int16", op_aaa  Op.Mod "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Int.Int16", op_aaa  Op.Div "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Int.Int16", op_aaa  Op.Mod "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Int.Int16", op_aIa  Op.Shl "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Int.Int16", op_aIa  Op.Shra "bits16" dc_Int16 t_Data_Int_Int16)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Int.Int32", ELam (v0 t_Data_Int_Int32) $ prim_sizeof "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Int.Int32", buildPoke dc_Int32 t_Data_Int_Int32 "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Int.Int32", buildPeek dc_Int32 t_Data_Int_Int32 "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Int.Int32", prim_maxbound dc_Int32 t_Data_Int_Int32 "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Int.Int32", prim_minbound dc_Int32 t_Data_Int_Int32 "bits32")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Int.Int32", ELam v2_Int (create_integralCast_fromInt dc_Int32 r_bits32 (EVar v2_Int) t_Data_Int_Int32))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Int.Int32", ELam (v2 t_Data_Int_Int32) (create_integralCast_toInt dc_Int32 r_bits32 (EVar (v2 t_Data_Int_Int32))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Int.Int32", ELam v2_Integer (create_integralCast_fromInteger dc_Int32 r_bits32 (EVar v2_Integer) t_Data_Int_Int32))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Int.Int32", ELam (v2 t_Data_Int_Int32) (create_integralCast_toInteger dc_Int32 r_bits32 (EVar (v2 t_Data_Int_Int32))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Int.Int32", ELam (v2 t_Data_Int_Int32) (build_abs "bits32" dc_Int32 (EVar (v2 t_Data_Int_Int32))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Int.Int32", ELam (v2 t_Data_Int_Int32) (build_signum "bits32" dc_Int32 (EVar (v2 t_Data_Int_Int32)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Int.Int32", op_aaB  Op.Eq "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Int.Int32", op_aaB  Op.Gte "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Int.Int32", op_aaB  Op.Lte "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Int.Int32", op_aaB  Op.Gt "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Int.Int32", op_aaB  Op.Lt "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Int.Int32", op_aaa  Op.Add "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Int.Int32", op_aaa  Op.Sub "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Int.Int32", op_aaa  Op.Mul "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Int.Int32", op_aa  Op.Neg "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Int.Int32", op_aaa  Op.And "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Int.Int32", op_aaa  Op.Or "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Int.Int32", op_aaa  Op.Xor "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Int.Int32", op_aa  Op.Com "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Int.Int32", op_aaa  Op.Div "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Int.Int32", op_aaa  Op.Mod "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Int.Int32", op_aaa  Op.Div "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Int.Int32", op_aaa  Op.Mod "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Int.Int32", op_aIa  Op.Shl "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Int.Int32", op_aIa  Op.Shra "bits32" dc_Int32 t_Data_Int_Int32)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Int.Int64", ELam (v0 t_Data_Int_Int64) $ prim_sizeof "bits64")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Int.Int64", buildPoke dc_Int64 t_Data_Int_Int64 "bits64")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Int.Int64", buildPeek dc_Int64 t_Data_Int_Int64 "bits64")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Int.Int64", prim_maxbound dc_Int64 t_Data_Int_Int64 "bits64")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Int.Int64", prim_minbound dc_Int64 t_Data_Int_Int64 "bits64")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Int.Int64", ELam v2_Int (create_integralCast_fromInt dc_Int64 r_bits64 (EVar v2_Int) t_Data_Int_Int64))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Int.Int64", ELam (v2 t_Data_Int_Int64) (create_integralCast_toInt dc_Int64 r_bits64 (EVar (v2 t_Data_Int_Int64))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Int.Int64", ELam v2_Integer (create_integralCast_fromInteger dc_Int64 r_bits64 (EVar v2_Integer) t_Data_Int_Int64))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Int.Int64", ELam (v2 t_Data_Int_Int64) (create_integralCast_toInteger dc_Int64 r_bits64 (EVar (v2 t_Data_Int_Int64))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Int.Int64", ELam (v2 t_Data_Int_Int64) (build_abs "bits64" dc_Int64 (EVar (v2 t_Data_Int_Int64))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Int.Int64", ELam (v2 t_Data_Int_Int64) (build_signum "bits64" dc_Int64 (EVar (v2 t_Data_Int_Int64)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Int.Int64", op_aaB  Op.Eq "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Int.Int64", op_aaB  Op.Gte "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Int.Int64", op_aaB  Op.Lte "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Int.Int64", op_aaB  Op.Gt "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Int.Int64", op_aaB  Op.Lt "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Int.Int64", op_aaa  Op.Add "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Int.Int64", op_aaa  Op.Sub "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Int.Int64", op_aaa  Op.Mul "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Int.Int64", op_aa  Op.Neg "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Int.Int64", op_aaa  Op.And "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Int.Int64", op_aaa  Op.Or "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Int.Int64", op_aaa  Op.Xor "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Int.Int64", op_aa  Op.Com "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Int.Int64", op_aaa  Op.Div "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Int.Int64", op_aaa  Op.Mod "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Int.Int64", op_aaa  Op.Div "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Int.Int64", op_aaa  Op.Mod "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Int.Int64", op_aIa  Op.Shl "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Int.Int64", op_aIa  Op.Shra "bits64" dc_Int64 t_Data_Int_Int64)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Int.IntMax", ELam (v0 t_Data_Int_IntMax) $ prim_sizeof "bits<max>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Int.IntMax", buildPoke dc_IntMax t_Data_Int_IntMax "bits<max>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Int.IntMax", buildPeek dc_IntMax t_Data_Int_IntMax "bits<max>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Int.IntMax", prim_maxbound dc_IntMax t_Data_Int_IntMax "bits<max>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Int.IntMax", prim_minbound dc_IntMax t_Data_Int_IntMax "bits<max>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Int.IntMax", ELam v2_Int (create_integralCast_fromInt dc_IntMax r_bits_max_ (EVar v2_Int) t_Data_Int_IntMax))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Int.IntMax", ELam (v2 t_Data_Int_IntMax) (create_integralCast_toInt dc_IntMax r_bits_max_ (EVar (v2 t_Data_Int_IntMax))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Int.IntMax", ELam v2_Integer (create_integralCast_fromInteger dc_IntMax r_bits_max_ (EVar v2_Integer) t_Data_Int_IntMax))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Int.IntMax", ELam (v2 t_Data_Int_IntMax) (create_integralCast_toInteger dc_IntMax r_bits_max_ (EVar (v2 t_Data_Int_IntMax))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Int.IntMax", ELam (v2 t_Data_Int_IntMax) (build_abs "bits<max>" dc_IntMax (EVar (v2 t_Data_Int_IntMax))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Int.IntMax", ELam (v2 t_Data_Int_IntMax) (build_signum "bits<max>" dc_IntMax (EVar (v2 t_Data_Int_IntMax)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Int.IntMax", op_aaB  Op.Eq "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Int.IntMax", op_aaB  Op.Gte "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Int.IntMax", op_aaB  Op.Lte "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Int.IntMax", op_aaB  Op.Gt "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Int.IntMax", op_aaB  Op.Lt "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Int.IntMax", op_aaa  Op.Add "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Int.IntMax", op_aaa  Op.Sub "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Int.IntMax", op_aaa  Op.Mul "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Int.IntMax", op_aa  Op.Neg "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Int.IntMax", op_aaa  Op.And "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Int.IntMax", op_aaa  Op.Or "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Int.IntMax", op_aaa  Op.Xor "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Int.IntMax", op_aa  Op.Com "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Int.IntMax", op_aaa  Op.Div "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Int.IntMax", op_aaa  Op.Mod "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Int.IntMax", op_aaa  Op.Div "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Int.IntMax", op_aaa  Op.Mod "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Int.IntMax", op_aIa  Op.Shl "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Int.IntMax", op_aIa  Op.Shra "bits<max>" dc_IntMax t_Data_Int_IntMax)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Int.IntPtr", ELam (v0 t_Data_Int_IntPtr) $ prim_sizeof "bits<ptr>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Int.IntPtr", buildPoke dc_IntPtr t_Data_Int_IntPtr "bits<ptr>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Int.IntPtr", buildPeek dc_IntPtr t_Data_Int_IntPtr "bits<ptr>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Int.IntPtr", prim_maxbound dc_IntPtr t_Data_Int_IntPtr "bits<ptr>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Int.IntPtr", prim_minbound dc_IntPtr t_Data_Int_IntPtr "bits<ptr>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Int.IntPtr", ELam v2_Int (create_integralCast_fromInt dc_IntPtr r_bits_ptr_ (EVar v2_Int) t_Data_Int_IntPtr))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Int.IntPtr", ELam (v2 t_Data_Int_IntPtr) (create_integralCast_toInt dc_IntPtr r_bits_ptr_ (EVar (v2 t_Data_Int_IntPtr))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Int.IntPtr", ELam v2_Integer (create_integralCast_fromInteger dc_IntPtr r_bits_ptr_ (EVar v2_Integer) t_Data_Int_IntPtr))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Int.IntPtr", ELam (v2 t_Data_Int_IntPtr) (create_integralCast_toInteger dc_IntPtr r_bits_ptr_ (EVar (v2 t_Data_Int_IntPtr))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Int.IntPtr", ELam (v2 t_Data_Int_IntPtr) (build_abs "bits<ptr>" dc_IntPtr (EVar (v2 t_Data_Int_IntPtr))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Int.IntPtr", ELam (v2 t_Data_Int_IntPtr) (build_signum "bits<ptr>" dc_IntPtr (EVar (v2 t_Data_Int_IntPtr)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Int.IntPtr", op_aaB  Op.Eq "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Int.IntPtr", op_aaB  Op.Gte "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Int.IntPtr", op_aaB  Op.Lte "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Int.IntPtr", op_aaB  Op.Gt "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Int.IntPtr", op_aaB  Op.Lt "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Int.IntPtr", op_aaa  Op.Add "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Int.IntPtr", op_aaa  Op.Sub "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Int.IntPtr", op_aaa  Op.Mul "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Int.IntPtr", op_aa  Op.Neg "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Int.IntPtr", op_aaa  Op.And "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Int.IntPtr", op_aaa  Op.Or "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Int.IntPtr", op_aaa  Op.Xor "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Int.IntPtr", op_aa  Op.Com "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Int.IntPtr", op_aaa  Op.Div "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Int.IntPtr", op_aaa  Op.Mod "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Int.IntPtr", op_aaa  Op.Div "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Int.IntPtr", op_aaa  Op.Mod "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Int.IntPtr", op_aIa  Op.Shl "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Int.IntPtr", op_aIa  Op.Shra "bits<ptr>" dc_IntPtr t_Data_Int_IntPtr)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.Word", ELam (v0 t_Data_Word_Word) $ prim_sizeof "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.Word", buildPoke dc_Word t_Data_Word_Word "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.Word", buildPeek dc_Word t_Data_Word_Word "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.Word", prim_umaxbound dc_Word t_Data_Word_Word "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.Word", prim_uminbound dc_Word t_Data_Word_Word "bits32")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.Word", ELam v2_Int (create_uintegralCast_fromInt dc_Word r_bits32 (EVar v2_Int) t_Data_Word_Word))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.Word", ELam (v2 t_Data_Word_Word) (create_uintegralCast_toInt dc_Word r_bits32 (EVar (v2 t_Data_Word_Word))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.Word", ELam v2_Integer (create_uintegralCast_fromInteger dc_Word r_bits32 (EVar v2_Integer) t_Data_Word_Word))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.Word", ELam (v2 t_Data_Word_Word) (create_uintegralCast_toInteger dc_Word r_bits32 (EVar (v2 t_Data_Word_Word))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.Word", ELam (v2 t_Data_Word_Word) (build_uabs "bits32" dc_Word (EVar (v2 t_Data_Word_Word))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.Word", ELam (v2 t_Data_Word_Word) (build_usignum "bits32" dc_Word (EVar (v2 t_Data_Word_Word)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.Word", op_aaB  Op.Eq "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.Word", op_aaB  Op.UGte "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.Word", op_aaB  Op.ULte "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.Word", op_aaB  Op.UGt "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.Word", op_aaB  Op.ULt "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.Word", op_aaa  Op.Add "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.Word", op_aaa  Op.Sub "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.Word", op_aaa  Op.Mul "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.Word", op_aa  Op.Neg "bits32" dc_Word t_Data_Word_Word)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.Word", op_aaa  Op.And "bits32" dc_Word t_Data_Word_Word)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.Word", op_aaa  Op.Or "bits32" dc_Word t_Data_Word_Word)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.Word", op_aaa  Op.Xor "bits32" dc_Word t_Data_Word_Word)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.Word", op_aa  Op.Com "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.Word", op_aaa  Op.UDiv "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.Word", op_aaa  Op.UMod "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.Word", op_aaa  Op.UDiv "bits32" dc_Word t_Data_Word_Word)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.Word", op_aaa  Op.UMod "bits32" dc_Word t_Data_Word_Word)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.Word", op_aIa  Op.Shl "bits32" dc_Word t_Data_Word_Word)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.Word", op_aIa  Op.Shr "bits32" dc_Word t_Data_Word_Word)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.Word8", ELam (v0 t_Data_Word_Word8) $ prim_sizeof "bits8")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.Word8", buildPoke dc_Word8 t_Data_Word_Word8 "bits8")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.Word8", buildPeek dc_Word8 t_Data_Word_Word8 "bits8")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.Word8", prim_umaxbound dc_Word8 t_Data_Word_Word8 "bits8")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.Word8", prim_uminbound dc_Word8 t_Data_Word_Word8 "bits8")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.Word8", ELam v2_Int (create_uintegralCast_fromInt dc_Word8 r_bits8 (EVar v2_Int) t_Data_Word_Word8))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.Word8", ELam (v2 t_Data_Word_Word8) (create_uintegralCast_toInt dc_Word8 r_bits8 (EVar (v2 t_Data_Word_Word8))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.Word8", ELam v2_Integer (create_uintegralCast_fromInteger dc_Word8 r_bits8 (EVar v2_Integer) t_Data_Word_Word8))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.Word8", ELam (v2 t_Data_Word_Word8) (create_uintegralCast_toInteger dc_Word8 r_bits8 (EVar (v2 t_Data_Word_Word8))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.Word8", ELam (v2 t_Data_Word_Word8) (build_uabs "bits8" dc_Word8 (EVar (v2 t_Data_Word_Word8))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.Word8", ELam (v2 t_Data_Word_Word8) (build_usignum "bits8" dc_Word8 (EVar (v2 t_Data_Word_Word8)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.Word8", op_aaB  Op.Eq "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.Word8", op_aaB  Op.UGte "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.Word8", op_aaB  Op.ULte "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.Word8", op_aaB  Op.UGt "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.Word8", op_aaB  Op.ULt "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.Word8", op_aaa  Op.Add "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.Word8", op_aaa  Op.Sub "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.Word8", op_aaa  Op.Mul "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.Word8", op_aa  Op.Neg "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.Word8", op_aaa  Op.And "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.Word8", op_aaa  Op.Or "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.Word8", op_aaa  Op.Xor "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.Word8", op_aa  Op.Com "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.Word8", op_aaa  Op.UDiv "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.Word8", op_aaa  Op.UMod "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.Word8", op_aaa  Op.UDiv "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.Word8", op_aaa  Op.UMod "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.Word8", op_aIa  Op.Shl "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.Word8", op_aIa  Op.Shr "bits8" dc_Word8 t_Data_Word_Word8)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.Word16", ELam (v0 t_Data_Word_Word16) $ prim_sizeof "bits16")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.Word16", buildPoke dc_Word16 t_Data_Word_Word16 "bits16")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.Word16", buildPeek dc_Word16 t_Data_Word_Word16 "bits16")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.Word16", prim_umaxbound dc_Word16 t_Data_Word_Word16 "bits16")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.Word16", prim_uminbound dc_Word16 t_Data_Word_Word16 "bits16")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.Word16", ELam v2_Int (create_uintegralCast_fromInt dc_Word16 r_bits16 (EVar v2_Int) t_Data_Word_Word16))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.Word16", ELam (v2 t_Data_Word_Word16) (create_uintegralCast_toInt dc_Word16 r_bits16 (EVar (v2 t_Data_Word_Word16))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.Word16", ELam v2_Integer (create_uintegralCast_fromInteger dc_Word16 r_bits16 (EVar v2_Integer) t_Data_Word_Word16))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.Word16", ELam (v2 t_Data_Word_Word16) (create_uintegralCast_toInteger dc_Word16 r_bits16 (EVar (v2 t_Data_Word_Word16))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.Word16", ELam (v2 t_Data_Word_Word16) (build_uabs "bits16" dc_Word16 (EVar (v2 t_Data_Word_Word16))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.Word16", ELam (v2 t_Data_Word_Word16) (build_usignum "bits16" dc_Word16 (EVar (v2 t_Data_Word_Word16)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.Word16", op_aaB  Op.Eq "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.Word16", op_aaB  Op.UGte "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.Word16", op_aaB  Op.ULte "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.Word16", op_aaB  Op.UGt "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.Word16", op_aaB  Op.ULt "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.Word16", op_aaa  Op.Add "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.Word16", op_aaa  Op.Sub "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.Word16", op_aaa  Op.Mul "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.Word16", op_aa  Op.Neg "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.Word16", op_aaa  Op.And "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.Word16", op_aaa  Op.Or "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.Word16", op_aaa  Op.Xor "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.Word16", op_aa  Op.Com "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.Word16", op_aaa  Op.UDiv "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.Word16", op_aaa  Op.UMod "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.Word16", op_aaa  Op.UDiv "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.Word16", op_aaa  Op.UMod "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.Word16", op_aIa  Op.Shl "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.Word16", op_aIa  Op.Shr "bits16" dc_Word16 t_Data_Word_Word16)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.Word32", ELam (v0 t_Data_Word_Word32) $ prim_sizeof "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.Word32", buildPoke dc_Word32 t_Data_Word_Word32 "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.Word32", buildPeek dc_Word32 t_Data_Word_Word32 "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.Word32", prim_umaxbound dc_Word32 t_Data_Word_Word32 "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.Word32", prim_uminbound dc_Word32 t_Data_Word_Word32 "bits32")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.Word32", ELam v2_Int (create_uintegralCast_fromInt dc_Word32 r_bits32 (EVar v2_Int) t_Data_Word_Word32))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.Word32", ELam (v2 t_Data_Word_Word32) (create_uintegralCast_toInt dc_Word32 r_bits32 (EVar (v2 t_Data_Word_Word32))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.Word32", ELam v2_Integer (create_uintegralCast_fromInteger dc_Word32 r_bits32 (EVar v2_Integer) t_Data_Word_Word32))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.Word32", ELam (v2 t_Data_Word_Word32) (create_uintegralCast_toInteger dc_Word32 r_bits32 (EVar (v2 t_Data_Word_Word32))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.Word32", ELam (v2 t_Data_Word_Word32) (build_uabs "bits32" dc_Word32 (EVar (v2 t_Data_Word_Word32))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.Word32", ELam (v2 t_Data_Word_Word32) (build_usignum "bits32" dc_Word32 (EVar (v2 t_Data_Word_Word32)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.Word32", op_aaB  Op.Eq "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.Word32", op_aaB  Op.UGte "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.Word32", op_aaB  Op.ULte "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.Word32", op_aaB  Op.UGt "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.Word32", op_aaB  Op.ULt "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.Word32", op_aaa  Op.Add "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.Word32", op_aaa  Op.Sub "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.Word32", op_aaa  Op.Mul "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.Word32", op_aa  Op.Neg "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.Word32", op_aaa  Op.And "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.Word32", op_aaa  Op.Or "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.Word32", op_aaa  Op.Xor "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.Word32", op_aa  Op.Com "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.Word32", op_aaa  Op.UDiv "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.Word32", op_aaa  Op.UMod "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.Word32", op_aaa  Op.UDiv "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.Word32", op_aaa  Op.UMod "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.Word32", op_aIa  Op.Shl "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.Word32", op_aIa  Op.Shr "bits32" dc_Word32 t_Data_Word_Word32)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.Word64", ELam (v0 t_Data_Word_Word64) $ prim_sizeof "bits64")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.Word64", buildPoke dc_Word64 t_Data_Word_Word64 "bits64")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.Word64", buildPeek dc_Word64 t_Data_Word_Word64 "bits64")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.Word64", prim_umaxbound dc_Word64 t_Data_Word_Word64 "bits64")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.Word64", prim_uminbound dc_Word64 t_Data_Word_Word64 "bits64")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.Word64", ELam v2_Int (create_uintegralCast_fromInt dc_Word64 r_bits64 (EVar v2_Int) t_Data_Word_Word64))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.Word64", ELam (v2 t_Data_Word_Word64) (create_uintegralCast_toInt dc_Word64 r_bits64 (EVar (v2 t_Data_Word_Word64))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.Word64", ELam v2_Integer (create_uintegralCast_fromInteger dc_Word64 r_bits64 (EVar v2_Integer) t_Data_Word_Word64))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.Word64", ELam (v2 t_Data_Word_Word64) (create_uintegralCast_toInteger dc_Word64 r_bits64 (EVar (v2 t_Data_Word_Word64))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.Word64", ELam (v2 t_Data_Word_Word64) (build_uabs "bits64" dc_Word64 (EVar (v2 t_Data_Word_Word64))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.Word64", ELam (v2 t_Data_Word_Word64) (build_usignum "bits64" dc_Word64 (EVar (v2 t_Data_Word_Word64)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.Word64", op_aaB  Op.Eq "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.Word64", op_aaB  Op.UGte "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.Word64", op_aaB  Op.ULte "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.Word64", op_aaB  Op.UGt "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.Word64", op_aaB  Op.ULt "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.Word64", op_aaa  Op.Add "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.Word64", op_aaa  Op.Sub "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.Word64", op_aaa  Op.Mul "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.Word64", op_aa  Op.Neg "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.Word64", op_aaa  Op.And "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.Word64", op_aaa  Op.Or "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.Word64", op_aaa  Op.Xor "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.Word64", op_aa  Op.Com "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.Word64", op_aaa  Op.UDiv "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.Word64", op_aaa  Op.UMod "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.Word64", op_aaa  Op.UDiv "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.Word64", op_aaa  Op.UMod "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.Word64", op_aIa  Op.Shl "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.Word64", op_aIa  Op.Shr "bits64" dc_Word64 t_Data_Word_Word64)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.WordMax", ELam (v0 t_Data_Word_WordMax) $ prim_sizeof "bits<max>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.WordMax", buildPoke dc_WordMax t_Data_Word_WordMax "bits<max>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.WordMax", buildPeek dc_WordMax t_Data_Word_WordMax "bits<max>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.WordMax", prim_umaxbound dc_WordMax t_Data_Word_WordMax "bits<max>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.WordMax", prim_uminbound dc_WordMax t_Data_Word_WordMax "bits<max>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.WordMax", ELam v2_Int (create_uintegralCast_fromInt dc_WordMax r_bits_max_ (EVar v2_Int) t_Data_Word_WordMax))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.WordMax", ELam (v2 t_Data_Word_WordMax) (create_uintegralCast_toInt dc_WordMax r_bits_max_ (EVar (v2 t_Data_Word_WordMax))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.WordMax", ELam v2_Integer (create_uintegralCast_fromInteger dc_WordMax r_bits_max_ (EVar v2_Integer) t_Data_Word_WordMax))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.WordMax", ELam (v2 t_Data_Word_WordMax) (create_uintegralCast_toInteger dc_WordMax r_bits_max_ (EVar (v2 t_Data_Word_WordMax))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.WordMax", ELam (v2 t_Data_Word_WordMax) (build_uabs "bits<max>" dc_WordMax (EVar (v2 t_Data_Word_WordMax))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.WordMax", ELam (v2 t_Data_Word_WordMax) (build_usignum "bits<max>" dc_WordMax (EVar (v2 t_Data_Word_WordMax)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.WordMax", op_aaB  Op.Eq "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.WordMax", op_aaB  Op.UGte "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.WordMax", op_aaB  Op.ULte "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.WordMax", op_aaB  Op.UGt "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.WordMax", op_aaB  Op.ULt "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.WordMax", op_aaa  Op.Add "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.WordMax", op_aaa  Op.Sub "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.WordMax", op_aaa  Op.Mul "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.WordMax", op_aa  Op.Neg "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.WordMax", op_aaa  Op.And "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.WordMax", op_aaa  Op.Or "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.WordMax", op_aaa  Op.Xor "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.WordMax", op_aa  Op.Com "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.WordMax", op_aaa  Op.UDiv "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.WordMax", op_aaa  Op.UMod "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.WordMax", op_aaa  Op.UDiv "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.WordMax", op_aaa  Op.UMod "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.WordMax", op_aIa  Op.Shl "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.WordMax", op_aIa  Op.Shr "bits<max>" dc_WordMax t_Data_Word_WordMax)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Data.Word.WordPtr", ELam (v0 t_Data_Word_WordPtr) $ prim_sizeof "bits<ptr>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Data.Word.WordPtr", buildPoke dc_WordPtr t_Data_Word_WordPtr "bits<ptr>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Data.Word.WordPtr", buildPeek dc_WordPtr t_Data_Word_WordPtr "bits<ptr>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Data.Word.WordPtr", prim_umaxbound dc_WordPtr t_Data_Word_WordPtr "bits<ptr>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Data.Word.WordPtr", prim_uminbound dc_WordPtr t_Data_Word_WordPtr "bits<ptr>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Data.Word.WordPtr", ELam v2_Int (create_uintegralCast_fromInt dc_WordPtr r_bits_ptr_ (EVar v2_Int) t_Data_Word_WordPtr))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Data.Word.WordPtr", ELam (v2 t_Data_Word_WordPtr) (create_uintegralCast_toInt dc_WordPtr r_bits_ptr_ (EVar (v2 t_Data_Word_WordPtr))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Data.Word.WordPtr", ELam v2_Integer (create_uintegralCast_fromInteger dc_WordPtr r_bits_ptr_ (EVar v2_Integer) t_Data_Word_WordPtr))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Data.Word.WordPtr", ELam (v2 t_Data_Word_WordPtr) (create_uintegralCast_toInteger dc_WordPtr r_bits_ptr_ (EVar (v2 t_Data_Word_WordPtr))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Data.Word.WordPtr", ELam (v2 t_Data_Word_WordPtr) (build_uabs "bits<ptr>" dc_WordPtr (EVar (v2 t_Data_Word_WordPtr))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Data.Word.WordPtr", ELam (v2 t_Data_Word_WordPtr) (build_usignum "bits<ptr>" dc_WordPtr (EVar (v2 t_Data_Word_WordPtr)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Data.Word.WordPtr", op_aaB  Op.Eq "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Data.Word.WordPtr", op_aaB  Op.UGte "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Data.Word.WordPtr", op_aaB  Op.ULte "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Data.Word.WordPtr", op_aaB  Op.UGt "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Data.Word.WordPtr", op_aaB  Op.ULt "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Data.Word.WordPtr", op_aaa  Op.Add "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Data.Word.WordPtr", op_aaa  Op.Sub "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Data.Word.WordPtr", op_aaa  Op.Mul "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Data.Word.WordPtr", op_aa  Op.Neg "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Data.Word.WordPtr", op_aaa  Op.And "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Data.Word.WordPtr", op_aaa  Op.Or "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Data.Word.WordPtr", op_aaa  Op.Xor "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Data.Word.WordPtr", op_aa  Op.Com "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Data.Word.WordPtr", op_aaa  Op.UDiv "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Data.Word.WordPtr", op_aaa  Op.UMod "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Data.Word.WordPtr", op_aaa  Op.UDiv "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Data.Word.WordPtr", op_aaa  Op.UMod "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Data.Word.WordPtr", op_aIa  Op.Shl "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Data.Word.WordPtr", op_aIa  Op.Shr "bits<ptr>" dc_WordPtr t_Data_Word_WordPtr)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CChar", ELam (v0 t_Foreign_C_Types_CChar) $ prim_sizeof "bits8")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CChar", buildPoke dc_CChar t_Foreign_C_Types_CChar "bits8")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CChar", buildPeek dc_CChar t_Foreign_C_Types_CChar "bits8")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CChar", prim_maxbound dc_CChar t_Foreign_C_Types_CChar "bits8")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CChar", prim_minbound dc_CChar t_Foreign_C_Types_CChar "bits8")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CChar", ELam v2_Int (create_integralCast_fromInt dc_CChar r_bits8 (EVar v2_Int) t_Foreign_C_Types_CChar))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CChar", ELam (v2 t_Foreign_C_Types_CChar) (create_integralCast_toInt dc_CChar r_bits8 (EVar (v2 t_Foreign_C_Types_CChar))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CChar", ELam v2_Integer (create_integralCast_fromInteger dc_CChar r_bits8 (EVar v2_Integer) t_Foreign_C_Types_CChar))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CChar", ELam (v2 t_Foreign_C_Types_CChar) (create_integralCast_toInteger dc_CChar r_bits8 (EVar (v2 t_Foreign_C_Types_CChar))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CChar", ELam (v2 t_Foreign_C_Types_CChar) (build_abs "bits8" dc_CChar (EVar (v2 t_Foreign_C_Types_CChar))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CChar", ELam (v2 t_Foreign_C_Types_CChar) (build_signum "bits8" dc_CChar (EVar (v2 t_Foreign_C_Types_CChar)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CChar", op_aaB  Op.Eq "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CChar", op_aaB  Op.Gte "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CChar", op_aaB  Op.Lte "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CChar", op_aaB  Op.Gt "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CChar", op_aaB  Op.Lt "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CChar", op_aaa  Op.Add "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CChar", op_aaa  Op.Sub "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CChar", op_aaa  Op.Mul "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CChar", op_aa  Op.Neg "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CChar", op_aaa  Op.And "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CChar", op_aaa  Op.Or "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CChar", op_aaa  Op.Xor "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CChar", op_aa  Op.Com "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CChar", op_aaa  Op.Div "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CChar", op_aaa  Op.Mod "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CChar", op_aaa  Op.Div "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CChar", op_aaa  Op.Mod "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CChar", op_aIa  Op.Shl "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CChar", op_aIa  Op.Shra "bits8" dc_CChar t_Foreign_C_Types_CChar)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CShort", ELam (v0 t_Foreign_C_Types_CShort) $ prim_sizeof "bits<short>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CShort", buildPoke dc_CShort t_Foreign_C_Types_CShort "bits<short>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CShort", buildPeek dc_CShort t_Foreign_C_Types_CShort "bits<short>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CShort", prim_maxbound dc_CShort t_Foreign_C_Types_CShort "bits<short>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CShort", prim_minbound dc_CShort t_Foreign_C_Types_CShort "bits<short>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CShort", ELam v2_Int (create_integralCast_fromInt dc_CShort r_bits_short_ (EVar v2_Int) t_Foreign_C_Types_CShort))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CShort", ELam (v2 t_Foreign_C_Types_CShort) (create_integralCast_toInt dc_CShort r_bits_short_ (EVar (v2 t_Foreign_C_Types_CShort))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CShort", ELam v2_Integer (create_integralCast_fromInteger dc_CShort r_bits_short_ (EVar v2_Integer) t_Foreign_C_Types_CShort))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CShort", ELam (v2 t_Foreign_C_Types_CShort) (create_integralCast_toInteger dc_CShort r_bits_short_ (EVar (v2 t_Foreign_C_Types_CShort))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CShort", ELam (v2 t_Foreign_C_Types_CShort) (build_abs "bits<short>" dc_CShort (EVar (v2 t_Foreign_C_Types_CShort))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CShort", ELam (v2 t_Foreign_C_Types_CShort) (build_signum "bits<short>" dc_CShort (EVar (v2 t_Foreign_C_Types_CShort)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CShort", op_aaB  Op.Eq "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CShort", op_aaB  Op.Gte "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CShort", op_aaB  Op.Lte "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CShort", op_aaB  Op.Gt "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CShort", op_aaB  Op.Lt "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CShort", op_aaa  Op.Add "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CShort", op_aaa  Op.Sub "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CShort", op_aaa  Op.Mul "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CShort", op_aa  Op.Neg "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CShort", op_aaa  Op.And "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CShort", op_aaa  Op.Or "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CShort", op_aaa  Op.Xor "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CShort", op_aa  Op.Com "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CShort", op_aaa  Op.Div "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CShort", op_aaa  Op.Mod "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CShort", op_aaa  Op.Div "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CShort", op_aaa  Op.Mod "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CShort", op_aIa  Op.Shl "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CShort", op_aIa  Op.Shra "bits<short>" dc_CShort t_Foreign_C_Types_CShort)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CInt", ELam (v0 t_Foreign_C_Types_CInt) $ prim_sizeof "bits<int>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CInt", buildPoke dc_CInt t_Foreign_C_Types_CInt "bits<int>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CInt", buildPeek dc_CInt t_Foreign_C_Types_CInt "bits<int>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CInt", prim_maxbound dc_CInt t_Foreign_C_Types_CInt "bits<int>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CInt", prim_minbound dc_CInt t_Foreign_C_Types_CInt "bits<int>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CInt", ELam v2_Int (create_integralCast_fromInt dc_CInt r_bits_int_ (EVar v2_Int) t_Foreign_C_Types_CInt))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CInt", ELam (v2 t_Foreign_C_Types_CInt) (create_integralCast_toInt dc_CInt r_bits_int_ (EVar (v2 t_Foreign_C_Types_CInt))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CInt", ELam v2_Integer (create_integralCast_fromInteger dc_CInt r_bits_int_ (EVar v2_Integer) t_Foreign_C_Types_CInt))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CInt", ELam (v2 t_Foreign_C_Types_CInt) (create_integralCast_toInteger dc_CInt r_bits_int_ (EVar (v2 t_Foreign_C_Types_CInt))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CInt", ELam (v2 t_Foreign_C_Types_CInt) (build_abs "bits<int>" dc_CInt (EVar (v2 t_Foreign_C_Types_CInt))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CInt", ELam (v2 t_Foreign_C_Types_CInt) (build_signum "bits<int>" dc_CInt (EVar (v2 t_Foreign_C_Types_CInt)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CInt", op_aaB  Op.Eq "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CInt", op_aaB  Op.Gte "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CInt", op_aaB  Op.Lte "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CInt", op_aaB  Op.Gt "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CInt", op_aaB  Op.Lt "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CInt", op_aaa  Op.Add "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CInt", op_aaa  Op.Sub "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CInt", op_aaa  Op.Mul "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CInt", op_aa  Op.Neg "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CInt", op_aaa  Op.And "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CInt", op_aaa  Op.Or "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CInt", op_aaa  Op.Xor "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CInt", op_aa  Op.Com "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CInt", op_aaa  Op.Div "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CInt", op_aaa  Op.Mod "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CInt", op_aaa  Op.Div "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CInt", op_aaa  Op.Mod "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CInt", op_aIa  Op.Shl "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CInt", op_aIa  Op.Shra "bits<int>" dc_CInt t_Foreign_C_Types_CInt)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CUInt", ELam (v0 t_Foreign_C_Types_CUInt) $ prim_sizeof "bits<int>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CUInt", buildPoke dc_CUInt t_Foreign_C_Types_CUInt "bits<int>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CUInt", buildPeek dc_CUInt t_Foreign_C_Types_CUInt "bits<int>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CUInt", prim_umaxbound dc_CUInt t_Foreign_C_Types_CUInt "bits<int>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CUInt", prim_uminbound dc_CUInt t_Foreign_C_Types_CUInt "bits<int>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CUInt", ELam v2_Int (create_uintegralCast_fromInt dc_CUInt r_bits_int_ (EVar v2_Int) t_Foreign_C_Types_CUInt))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CUInt", ELam (v2 t_Foreign_C_Types_CUInt) (create_uintegralCast_toInt dc_CUInt r_bits_int_ (EVar (v2 t_Foreign_C_Types_CUInt))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CUInt", ELam v2_Integer (create_uintegralCast_fromInteger dc_CUInt r_bits_int_ (EVar v2_Integer) t_Foreign_C_Types_CUInt))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CUInt", ELam (v2 t_Foreign_C_Types_CUInt) (create_uintegralCast_toInteger dc_CUInt r_bits_int_ (EVar (v2 t_Foreign_C_Types_CUInt))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CUInt", ELam (v2 t_Foreign_C_Types_CUInt) (build_uabs "bits<int>" dc_CUInt (EVar (v2 t_Foreign_C_Types_CUInt))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CUInt", ELam (v2 t_Foreign_C_Types_CUInt) (build_usignum "bits<int>" dc_CUInt (EVar (v2 t_Foreign_C_Types_CUInt)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CUInt", op_aaB  Op.Eq "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CUInt", op_aaB  Op.UGte "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CUInt", op_aaB  Op.ULte "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CUInt", op_aaB  Op.UGt "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CUInt", op_aaB  Op.ULt "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CUInt", op_aaa  Op.Add "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CUInt", op_aaa  Op.Sub "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CUInt", op_aaa  Op.Mul "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CUInt", op_aa  Op.Neg "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CUInt", op_aaa  Op.And "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CUInt", op_aaa  Op.Or "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CUInt", op_aaa  Op.Xor "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CUInt", op_aa  Op.Com "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CUInt", op_aaa  Op.UDiv "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CUInt", op_aaa  Op.UMod "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CUInt", op_aaa  Op.UDiv "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CUInt", op_aaa  Op.UMod "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CUInt", op_aIa  Op.Shl "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CUInt", op_aIa  Op.Shr "bits<int>" dc_CUInt t_Foreign_C_Types_CUInt)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CSize", ELam (v0 t_Foreign_C_Types_CSize) $ prim_sizeof "bits<size_t>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CSize", buildPoke dc_CSize t_Foreign_C_Types_CSize "bits<size_t>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CSize", buildPeek dc_CSize t_Foreign_C_Types_CSize "bits<size_t>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CSize", prim_umaxbound dc_CSize t_Foreign_C_Types_CSize "bits<size_t>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CSize", prim_uminbound dc_CSize t_Foreign_C_Types_CSize "bits<size_t>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CSize", ELam v2_Int (create_uintegralCast_fromInt dc_CSize r_bits_size_t_ (EVar v2_Int) t_Foreign_C_Types_CSize))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CSize", ELam (v2 t_Foreign_C_Types_CSize) (create_uintegralCast_toInt dc_CSize r_bits_size_t_ (EVar (v2 t_Foreign_C_Types_CSize))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CSize", ELam v2_Integer (create_uintegralCast_fromInteger dc_CSize r_bits_size_t_ (EVar v2_Integer) t_Foreign_C_Types_CSize))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CSize", ELam (v2 t_Foreign_C_Types_CSize) (create_uintegralCast_toInteger dc_CSize r_bits_size_t_ (EVar (v2 t_Foreign_C_Types_CSize))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CSize", ELam (v2 t_Foreign_C_Types_CSize) (build_uabs "bits<size_t>" dc_CSize (EVar (v2 t_Foreign_C_Types_CSize))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CSize", ELam (v2 t_Foreign_C_Types_CSize) (build_usignum "bits<size_t>" dc_CSize (EVar (v2 t_Foreign_C_Types_CSize)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CSize", op_aaB  Op.Eq "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CSize", op_aaB  Op.UGte "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CSize", op_aaB  Op.ULte "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CSize", op_aaB  Op.UGt "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CSize", op_aaB  Op.ULt "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CSize", op_aaa  Op.Add "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CSize", op_aaa  Op.Sub "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CSize", op_aaa  Op.Mul "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CSize", op_aa  Op.Neg "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CSize", op_aaa  Op.And "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CSize", op_aaa  Op.Or "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CSize", op_aaa  Op.Xor "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CSize", op_aa  Op.Com "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CSize", op_aaa  Op.UDiv "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CSize", op_aaa  Op.UMod "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CSize", op_aaa  Op.UDiv "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CSize", op_aaa  Op.UMod "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CSize", op_aIa  Op.Shl "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CSize", op_aIa  Op.Shr "bits<size_t>" dc_CSize t_Foreign_C_Types_CSize)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CWchar", ELam (v0 t_Foreign_C_Types_CWchar) $ prim_sizeof "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CWchar", buildPoke dc_CWchar t_Foreign_C_Types_CWchar "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CWchar", buildPeek dc_CWchar t_Foreign_C_Types_CWchar "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CWchar", prim_umaxbound dc_CWchar t_Foreign_C_Types_CWchar "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CWchar", prim_uminbound dc_CWchar t_Foreign_C_Types_CWchar "bits32")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CWchar", ELam v2_Int (create_uintegralCast_fromInt dc_CWchar r_bits32 (EVar v2_Int) t_Foreign_C_Types_CWchar))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CWchar", ELam (v2 t_Foreign_C_Types_CWchar) (create_uintegralCast_toInt dc_CWchar r_bits32 (EVar (v2 t_Foreign_C_Types_CWchar))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CWchar", ELam v2_Integer (create_uintegralCast_fromInteger dc_CWchar r_bits32 (EVar v2_Integer) t_Foreign_C_Types_CWchar))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CWchar", ELam (v2 t_Foreign_C_Types_CWchar) (create_uintegralCast_toInteger dc_CWchar r_bits32 (EVar (v2 t_Foreign_C_Types_CWchar))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CWchar", ELam (v2 t_Foreign_C_Types_CWchar) (build_uabs "bits32" dc_CWchar (EVar (v2 t_Foreign_C_Types_CWchar))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CWchar", ELam (v2 t_Foreign_C_Types_CWchar) (build_usignum "bits32" dc_CWchar (EVar (v2 t_Foreign_C_Types_CWchar)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CWchar", op_aaB  Op.Eq "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CWchar", op_aaB  Op.UGte "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CWchar", op_aaB  Op.ULte "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CWchar", op_aaB  Op.UGt "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CWchar", op_aaB  Op.ULt "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CWchar", op_aaa  Op.Add "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CWchar", op_aaa  Op.Sub "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CWchar", op_aaa  Op.Mul "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CWchar", op_aa  Op.Neg "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CWchar", op_aaa  Op.And "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CWchar", op_aaa  Op.Or "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CWchar", op_aaa  Op.Xor "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CWchar", op_aa  Op.Com "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CWchar", op_aaa  Op.UDiv "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CWchar", op_aaa  Op.UMod "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CWchar", op_aaa  Op.UDiv "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CWchar", op_aaa  Op.UMod "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CWchar", op_aIa  Op.Shl "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CWchar", op_aIa  Op.Shr "bits32" dc_CWchar t_Foreign_C_Types_CWchar)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CWint", ELam (v0 t_Foreign_C_Types_CWint) $ prim_sizeof "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CWint", buildPoke dc_CWint t_Foreign_C_Types_CWint "bits32")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CWint", buildPeek dc_CWint t_Foreign_C_Types_CWint "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CWint", prim_maxbound dc_CWint t_Foreign_C_Types_CWint "bits32")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CWint", prim_minbound dc_CWint t_Foreign_C_Types_CWint "bits32")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CWint", ELam v2_Int (create_integralCast_fromInt dc_CWint r_bits32 (EVar v2_Int) t_Foreign_C_Types_CWint))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInt.Foreign.C.Types.CWint", ELam (v2 t_Foreign_C_Types_CWint) (create_integralCast_toInt dc_CWint r_bits32 (EVar (v2 t_Foreign_C_Types_CWint))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CWint", ELam v2_Integer (create_integralCast_fromInteger dc_CWint r_bits32 (EVar v2_Integer) t_Foreign_C_Types_CWint))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.toInteger.Foreign.C.Types.CWint", ELam (v2 t_Foreign_C_Types_CWint) (create_integralCast_toInteger dc_CWint r_bits32 (EVar (v2 t_Foreign_C_Types_CWint))))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CWint", ELam (v2 t_Foreign_C_Types_CWint) (build_abs "bits32" dc_CWint (EVar (v2 t_Foreign_C_Types_CWint))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CWint", ELam (v2 t_Foreign_C_Types_CWint) (build_signum "bits32" dc_CWint (EVar (v2 t_Foreign_C_Types_CWint)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CWint", op_aaB  Op.Eq "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CWint", op_aaB  Op.Gte "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CWint", op_aaB  Op.Lte "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CWint", op_aaB  Op.Gt "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CWint", op_aaB  Op.Lt "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CWint", op_aaa  Op.Add "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CWint", op_aaa  Op.Sub "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CWint", op_aaa  Op.Mul "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CWint", op_aa  Op.Neg "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..&..Foreign.C.Types.CWint", op_aaa  Op.And "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits..|..Foreign.C.Types.CWint", op_aaa  Op.Or "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.xor.Foreign.C.Types.CWint", op_aaa  Op.Xor "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.complement.Foreign.C.Types.CWint", op_aa  Op.Com "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.quot.Foreign.C.Types.CWint", op_aaa  Op.Div "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.rem.Foreign.C.Types.CWint", op_aaa  Op.Mod "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.div.Foreign.C.Types.CWint", op_aaa  Op.Div "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Lhc_Num_Integral,toInstName "Lhc.Num.mod.Foreign.C.Types.CWint", op_aaa  Op.Mod "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftL.Foreign.C.Types.CWint", op_aIa  Op.Shl "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Data_Bits_Bits,toInstName "Data.Bits.shiftR.Foreign.C.Types.CWint", op_aIa  Op.Shra "bits32" dc_CWint t_Foreign_C_Types_CWint)-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.sizeOf.Foreign.C.Types.CTime", ELam (v0 t_Foreign_C_Types_CTime) $ prim_sizeof "bits<time_t>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.poke.Foreign.C.Types.CTime", buildPoke dc_CTime t_Foreign_C_Types_CTime "bits<time_t>")-  ,(n_Foreign_Storable_Storable, toInstName "Foreign.Storable.peek.Foreign.C.Types.CTime", buildPeek dc_CTime t_Foreign_C_Types_CTime "bits<time_t>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.maxBound.Foreign.C.Types.CTime", prim_umaxbound dc_CTime t_Foreign_C_Types_CTime "bits<time_t>")-  ,(n_Lhc_Enum_Bounded, toInstName "Lhc.Enum.minBound.Foreign.C.Types.CTime", prim_uminbound dc_CTime t_Foreign_C_Types_CTime "bits<time_t>")-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInt.Foreign.C.Types.CTime", ELam v2_Int (create_uintegralCast_fromInt dc_CTime r_bits_time_t_ (EVar v2_Int) t_Foreign_C_Types_CTime))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.fromInteger.Foreign.C.Types.CTime", ELam v2_Integer (create_uintegralCast_fromInteger dc_CTime r_bits_time_t_ (EVar v2_Integer) t_Foreign_C_Types_CTime))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.abs.Foreign.C.Types.CTime", ELam (v2 t_Foreign_C_Types_CTime) (build_uabs "bits<time_t>" dc_CTime (EVar (v2 t_Foreign_C_Types_CTime))  ))-  ,(n_Lhc_Num_Num, toInstName "Lhc.Num.signum.Foreign.C.Types.CTime", ELam (v2 t_Foreign_C_Types_CTime) (build_usignum "bits<time_t>" dc_CTime (EVar (v2 t_Foreign_C_Types_CTime)) ))-  ,(n_Lhc_Order_Eq,toInstName "Lhc.Order.==.Foreign.C.Types.CTime", op_aaB  Op.Eq "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>=.Foreign.C.Types.CTime", op_aaB  Op.UGte "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<=.Foreign.C.Types.CTime", op_aaB  Op.ULte "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.>.Foreign.C.Types.CTime", op_aaB  Op.UGt "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Order_Ord,toInstName "Lhc.Order.<.Foreign.C.Types.CTime", op_aaB  Op.ULt "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.+.Foreign.C.Types.CTime", op_aaa  Op.Add "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.-.Foreign.C.Types.CTime", op_aaa  Op.Sub "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.*.Foreign.C.Types.CTime", op_aaa  Op.Mul "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime)-  ,(n_Lhc_Num_Num,toInstName "Lhc.Num.negate.Foreign.C.Types.CTime", op_aa  Op.Neg "bits<time_t>" dc_CTime t_Foreign_C_Types_CTime) ]--theMethods = [-    ]--allCTypes = [-   (dc_Int, tc_Int, r_bits32, "bits32", "int")-  ,(dc_Integer, tc_Integer, r_bits_max_, "bits<max>", "int")-  ,(dc_Int8, tc_Int8, r_bits8, "bits8", "int")-  ,(dc_Int16, tc_Int16, r_bits16, "bits16", "int")-  ,(dc_Int32, tc_Int32, r_bits32, "bits32", "int")-  ,(dc_Int64, tc_Int64, r_bits64, "bits64", "int")-  ,(dc_IntMax, tc_IntMax, r_bits_max_, "bits<max>", "int")-  ,(dc_IntPtr, tc_IntPtr, r_bits_ptr_, "bits<ptr>", "int")-  ,(dc_Word, tc_Word, r_bits32, "bits32", "int")-  ,(dc_Word8, tc_Word8, r_bits8, "bits8", "int")-  ,(dc_Word16, tc_Word16, r_bits16, "bits16", "int")-  ,(dc_Word32, tc_Word32, r_bits32, "bits32", "int")-  ,(dc_Word64, tc_Word64, r_bits64, "bits64", "int")-  ,(dc_WordMax, tc_WordMax, r_bits_max_, "bits<max>", "int")-  ,(dc_WordPtr, tc_WordPtr, r_bits_ptr_, "bits<ptr>", "int")-  ,(dc_CChar, tc_CChar, r_bits8, "bits8", "int")-  ,(dc_CShort, tc_CShort, r_bits_short_, "bits<short>", "int")-  ,(dc_CInt, tc_CInt, r_bits_int_, "bits<int>", "int")-  ,(dc_CUInt, tc_CUInt, r_bits_int_, "bits<int>", "int")-  ,(dc_CSize, tc_CSize, r_bits_size_t_, "bits<size_t>", "int")-  ,(dc_CWchar, tc_CWchar, r_bits32, "bits32", "int")-  ,(dc_CWint, tc_CWint, r_bits32, "bits32", "int")-  ,(dc_CTime, tc_CTime, r_bits_time_t_, "bits<time_t>", "float")- ]--t_Data_Word_WordMax = ELit litCons { litName = tc_WordMax, litType = eStar}-t_Lhc_Basics_Integer = ELit litCons { litName = tc_Integer, litType = eStar}-t_Foreign_C_Types_CInt = ELit litCons { litName = tc_CInt, litType = eStar}-t_Data_Word_Word64 = ELit litCons { litName = tc_Word64, litType = eStar}-t_Data_Int_IntMax = ELit litCons { litName = tc_IntMax, litType = eStar}-t_Foreign_C_Types_CTime = ELit litCons { litName = tc_CTime, litType = eStar}-t_Foreign_C_Types_CShort = ELit litCons { litName = tc_CShort, litType = eStar}-t_Data_Int_Int8 = ELit litCons { litName = tc_Int8, litType = eStar}-t_Foreign_C_Types_CChar = ELit litCons { litName = tc_CChar, litType = eStar}-t_Lhc_Prim_Int = ELit litCons { litName = tc_Int, litType = eStar}-t_Data_Word_Word = ELit litCons { litName = tc_Word, litType = eStar}-t_Data_Int_Int16 = ELit litCons { litName = tc_Int16, litType = eStar}-t_Data_Word_Word8 = ELit litCons { litName = tc_Word8, litType = eStar}-t_Data_Word_Word32 = ELit litCons { litName = tc_Word32, litType = eStar}-t_Foreign_C_Types_CWchar = ELit litCons { litName = tc_CWchar, litType = eStar}-t_Foreign_C_Types_CSize = ELit litCons { litName = tc_CSize, litType = eStar}-t_Data_Word_Word16 = ELit litCons { litName = tc_Word16, litType = eStar}-t_Foreign_C_Types_CUInt = ELit litCons { litName = tc_CUInt, litType = eStar}-t_Data_Int_Int32 = ELit litCons { litName = tc_Int32, litType = eStar}-t_Foreign_C_Types_CWint = ELit litCons { litName = tc_CWint, litType = eStar}-t_Data_Int_Int64 = ELit litCons { litName = tc_Int64, litType = eStar}-t_Data_Int_IntPtr = ELit litCons { litName = tc_IntPtr, litType = eStar}-t_Data_Word_WordPtr = ELit litCons { litName = tc_WordPtr, litType = eStar}--tc_Data_Word_WordMax = TCon (Tycon tc_WordMax kindStar)-tc_Lhc_Basics_Integer = TCon (Tycon tc_Integer kindStar)-tc_Foreign_C_Types_CInt = TCon (Tycon tc_CInt kindStar)-tc_Data_Word_Word64 = TCon (Tycon tc_Word64 kindStar)-tc_Data_Int_IntMax = TCon (Tycon tc_IntMax kindStar)-tc_Foreign_C_Types_CTime = TCon (Tycon tc_CTime kindStar)-tc_Foreign_C_Types_CShort = TCon (Tycon tc_CShort kindStar)-tc_Data_Int_Int8 = TCon (Tycon tc_Int8 kindStar)-tc_Foreign_C_Types_CChar = TCon (Tycon tc_CChar kindStar)-tc_Lhc_Prim_Int = TCon (Tycon tc_Int kindStar)-tc_Data_Word_Word = TCon (Tycon tc_Word kindStar)-tc_Data_Int_Int16 = TCon (Tycon tc_Int16 kindStar)-tc_Data_Word_Word8 = TCon (Tycon tc_Word8 kindStar)-tc_Data_Word_Word32 = TCon (Tycon tc_Word32 kindStar)-tc_Foreign_C_Types_CWchar = TCon (Tycon tc_CWchar kindStar)-tc_Foreign_C_Types_CSize = TCon (Tycon tc_CSize kindStar)-tc_Data_Word_Word16 = TCon (Tycon tc_Word16 kindStar)-tc_Foreign_C_Types_CUInt = TCon (Tycon tc_CUInt kindStar)-tc_Data_Int_Int32 = TCon (Tycon tc_Int32 kindStar)-tc_Foreign_C_Types_CWint = TCon (Tycon tc_CWint kindStar)-tc_Data_Int_Int64 = TCon (Tycon tc_Int64 kindStar)-tc_Data_Int_IntPtr = TCon (Tycon tc_IntPtr kindStar)-tc_Data_Word_WordPtr = TCon (Tycon tc_WordPtr kindStar)--n_Lhc_Num_Integral = toClassName "Lhc.Num.Integral"-n_Lhc_Num_Num = toClassName "Lhc.Num.Num"-n_Data_Bits_Bits = toClassName "Data.Bits.Bits"-n_Lhc_Order_Eq = toClassName "Lhc.Order.Eq"-n_Lhc_Enum_Bounded = toClassName "Lhc.Enum.Bounded"-n_Lhc_Order_Ord = toClassName "Lhc.Order.Ord"-n_Foreign_Storable_Storable = toClassName "Foreign.Storable.Storable"--{-# NOINLINE n_Lhc_Num_Integral #-}-{-# NOINLINE n_Lhc_Num_Num #-}-{-# NOINLINE n_Data_Bits_Bits #-}-{-# NOINLINE n_Lhc_Order_Eq #-}-{-# NOINLINE n_Lhc_Enum_Bounded #-}-{-# NOINLINE n_Lhc_Order_Ord #-}-{-# NOINLINE n_Foreign_Storable_Storable #-}----r_bits_max_    = ELit litCons { litName = rt_bits_max_, litType = eHash }-r_bits_ptr_    = ELit litCons { litName = rt_bits_ptr_, litType = eHash }-r_bits_int_    = ELit litCons { litName = rt_bits_int_, litType = eHash }-r_bits32       = ELit litCons { litName = rt_bits32, litType = eHash }-r_bits_short_  = ELit litCons { litName = rt_bits_short_, litType = eHash }-r_bits_size_t_ = ELit litCons { litName = rt_bits_size_t_, litType = eHash }-r_bits_time_t_ = ELit litCons { litName = rt_bits_time_t_, litType = eHash }-r_bits8        = ELit litCons { litName = rt_bits8, litType = eHash }-r_bits16       = ELit litCons { litName = rt_bits16, litType = eHash }-r_bits64       = ELit litCons { litName = rt_bits64, litType = eHash }---
− src/RawFiles.hs 
@@ -1,34 +0,0 @@-module RawFiles where-import System.IO.Unsafe-import Paths_lhc--{-# NOINLINE hsffi_h #-}-hsffi_h :: String-hsffi_h = readf "HsFFI.h"--{-# NOINLINE lhc_rts_c #-}-lhc_rts_c :: String-lhc_rts_c = readf "rts/lhc_rts.c"--{-# NOINLINE lhc_rts_header_h #-}-lhc_rts_header_h :: String-lhc_rts_header_h = readf "rts/lhc_rts_header.h"--{-# NOINLINE wsize_h #-}-wsize_h :: String-wsize_h = readf "wsize.h"--{-# NOINLINE lhc_rts_alloc_c #-}-lhc_rts_alloc_c :: String-lhc_rts_alloc_c = readf "rts/lhc_rts_alloc.c"--{-# NOINLINE lhc_rts2_c #-}-lhc_rts2_c :: String-lhc_rts2_c = readf "rts/lhc_rts2.c"--{-# NOINLINE prelude_m4 #-}-prelude_m4 :: String-prelude_m4 = readf "prelude.m4"---- convenience-readf = unsafePerformIO . readFile . unsafePerformIO . getDataFileName
+ src/Setup.hs view
@@ -0,0 +1,35 @@+module Setup where+++import System.Exit+import System.Environment+import System.Console.GetOpt+import System.Directory+import System.IO+import Data.Maybe+import Data.Char++data Action+    = LibCheck+    | Install+    | Build+++data ConfigFlag+    = Help++parseArgs :: [String] -> IO (Action)+parseArgs args+    = case getOpt RequireOrder [] args of+        (flags, (cmdStr:args), []) | Just cmd <- lookup cmdStr commands+          -> do +                --exitWith ExitSuccess+                return cmd+        (flags, _, [])  -> do hPutStrLn stderr "Usage!"+                              exitWith ExitSuccess+        (flags, _, errs) -> do hPutStrLn stderr $ unlines errs+                               exitFailure++commands = [ ("install", Install)+           , ("libcheck", LibCheck) ]+
− src/Stats.hs 
@@ -1,264 +0,0 @@-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,-    mticks,-    runStatT,-    runStatIO,-    runStatM,-    -- combined-    tickStat-    ) where---import Char-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.Writer-import Data.IORef-import Data.Tree-import List(sort,groupBy)-import Prelude hiding(null)-import System.IO.Unsafe-import qualified Data.Map as Map-import qualified Prelude(null)--import StringTable.Atom-import CharIO-import GenUtil-import qualified Doc.Chars as C-import qualified Util.IntBag as IB-import Options (dump)-import qualified FlagDump as FD----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_ CharIO.putErrLn $ ( 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 (toAtom $ "{" ++ name ++ "}." ++ fromAtom (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_ CharIO.putErrLn $ ( 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_ CharIO.putErrLn $ ( 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-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 (CharIO.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-            CharIO.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-
− src/Support/CFF.hs 
@@ -1,289 +0,0 @@-{-# OPTIONS -funbox-strict-fields  -O2 #-}---- 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,-    readCFF,-    bsCFF,-    lbsCFF,-    mkCFFfile,-    readChunk,-    lazyWriteCFF,-    writeCFF-    )where--import Control.Monad-import Data.Bits-import Data.Char-import Data.List-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 'LHC'--- 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 [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 | fo `seq` True = 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.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 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/CanType.hs 
@@ -1,17 +0,0 @@-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 e | a -> e where-    getType :: a -> e---- This should perform a full typecheck and may take any extra information needed as an extra parameter-class CanTypeCheck env a ty | a -> ty env where-    typecheck :: Monad m => env -> a -> m ty--infertype :: CanTypeCheck env a ty => env -> a -> ty-infertype env a = case typecheck env a of-    Left s -> error $ "infertype: " ++ s-    Right x -> x-
− src/Support/FreeVars.hs 
@@ -1,29 +0,0 @@--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/ShowTable.hs 
@@ -1,24 +0,0 @@-module Support.ShowTable where--import Monad-import List-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/Tickle.hs 
@@ -1,16 +0,0 @@-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 
@@ -1,35 +0,0 @@-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 {-    transformIterate = DontIterate,-    transformDumpProgress = False,-    transformSkipNoStats = False,-    transformCategory = "Unknown",-    transformPass = "",-    transformOperation = return,-    transformName = ""-    }--data Iterate = DontIterate | IterateMax !Int | IterateExactly !Int | IterateDone-    deriving(Eq)--doIterate IterateMax {}     True = True-doIterate IterateDone       True = True-doIterate IterateExactly {} _    = True-doIterate _ _ = False--iterateStep (IterateMax n) = IterateMax (n - 1)-iterateStep (IterateExactly n) = IterateExactly (n - 1)-iterateStep x = x-
− src/Support/Tuple.hs 
@@ -1,25 +0,0 @@-module Support.Tuple where--import 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 
@@ -1,180 +0,0 @@-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/Traverse.hs view
@@ -0,0 +1,15 @@+module Traverse where++import Control.Monad.Identity+import Control.Monad.Writer+import Data.Monoid++class Traverse a where+    tmap   ::             (a -> a) -> a -> a+    tmapM  :: Monad m =>  (a -> m a) -> a -> m a+    tmapM_ :: Monad m =>  (a -> m b) -> a -> m a+    tsum   :: Monoid b => (a -> b) -> a -> b++    tmap fn = runIdentity . tmapM (return . fn)+    tmapM_ fn = tmapM (\a -> fn a >> return a)+    tsum fn = execWriter . tmapM_ (tell . fn)
− src/Util/ArbitraryInstances.hs 
@@ -1,25 +0,0 @@-module Util.ArbitraryInstances() where--import Test.QuickCheck-import Monad-import Char(chr)----instance Arbitrary a => Arbitrary (Maybe a) where---    arbitrary = do---        i <- choose ((0::Int),7)---        if i == 0 then return Nothing else do---            x <- arbitrary---            return (Just x)-    --coarbitrary Nothing = variant 0 . coarbitrary---instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where---    arbitrary = do---        i <- choose ((0::Int),1)---        case i of---            0 -> liftM Left arbitrary---            1 -> liftM Right arbitrary----instance Arbitrary Char where-    arbitrary = g where-        g = do-            c <- choose (0x20, 0xFF)-            if c > 0x7E && c < 0xA0 then g else return (chr c)
− src/Util/BitSet.hs 
@@ -1,87 +0,0 @@-{-# 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 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 v) = f 0 where-        f c | c >= 32 = []-            | otherwise = if testBit v c then c:f (c + 1) else f (c + 1)-    sfilter = error "sfilter not defined for BitSet"---instance Show BitSet where-    showsPrec n bs = showsPrec n (toList bs)---newtype EnumBitSet a = EnumBitSet BitSet-    deriving(Monoid,SetLike,HasSize,Eq,Ord,IsEmpty)--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 = error "sfilter not defined for EnumBitSet"--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 
@@ -1,246 +0,0 @@--- 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 
@@ -1,25 +0,0 @@-module Util.ContextMonad where--import Control.Monad.Error-import Control.Monad---class Monad m => ContextMonad c m | m -> c where-    withContext :: c -> m a -> m a---instance Error [String] where-    noMsg = []-    strMsg s = [s]---instance ContextMonad String (Either [String]) where-    withContext s (Right x) = Right x-    withContext s (Left cs) = Left  (s:cs)---runSimpleContextMonad :: Either [String] a -> a-runSimpleContextMonad (Left ss) = error $ unlines ss-runSimpleContextMonad (Right x) = x--
− src/Util/FilterInput.hs 
@@ -1,39 +0,0 @@-module Util.FilterInput (filterInput,readSystem) where--import CharIO-import Control.Monad (when)-import System-import System.IO(Handle)-import System.Posix---filterInput :: String -> [String] -> Handle -> IO String-filterInput prog args ifh = do-    (rfd,wfd) <- createPipe-    ifd <- handleToFd ifh-    pid <- forkProcess (do dupAndClose ifd stdInput-                           dupAndClose wfd stdOutput-                           executeFile prog True args Nothing-                           putErrDie "exec failed")-    closeFd wfd-    str <- hGetContents =<< fdToHandle rfd-    ret <- length str `seq` getProcessStatus True False pid-    when (ret /= Just (Exited ExitSuccess)) $ putErrDie (prog ++ " exited abnormally")-    return str--dupAndClose :: Fd -> Fd -> IO ()-dupAndClose from to = dupTo from to >> closeFd from--readSystem :: String -> [String] -> IO String-readSystem prog args = do-    (rfd,wfd) <- createPipe-    pid <- forkProcess (do dupAndClose wfd stdOutput-                           executeFile prog True args Nothing-                           putErrDie "exec failed")-    closeFd wfd-    str <- hGetContents =<< fdToHandle rfd-    ret <- length str `seq` getProcessStatus True False pid-    when (ret /= Just (Exited ExitSuccess)) $ putErrDie (prog ++ " exited abnormally")-    return str--
− src/Util/Gen.hs 
@@ -1,27 +0,0 @@---- | similar to GenUtil but can rely on non-haskell 98 features-module Util.Gen(module Util.Gen, module GenUtil) where--import Control.Monad.Writer-import Control.Monad.Identity-import Data.Monoid-import Data.List--import GenUtil hiding(replicateM)--mconcatMap f xs = mconcat (map f xs)-mintercalate x xs = mconcat (intersperse x xs)--mconcatMapM f xs = mapM f xs >>= return . mconcat---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 .. ])
− src/Util/Graph.hs 
@@ -1,91 +0,0 @@--- | Data.Graph is sorely lacking in several ways, This just tries to fill in--- some holes and provide a more convinient interface--module Util.Graph where--import Array-import Data.Graph hiding(Graph)-import GenUtil-import List(sort,sortBy,group,delete)-import qualified Data.Graph(Graph)---data Graph n k = Graph Data.Graph.Graph (Vertex -> n) (k -> Maybe Vertex) (n -> k)--instance Show n => Show (Graph n k) where-    showsPrec n g = showsPrec n (Util.Graph.scc g)--newGraph :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> Graph n k-newGraph ns fn fd = Graph ans lv' kv fn where-    (ans,lv,kv) = graphFromEdges [ (n,fn n,snub $ fd n) | n <- ns ]-    lv' x | (n,_,_) <- lv x = n--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 k  -- ^ the graph-    ->  ([n],[n]) -- ^ (loop breakers,dependency ordered nodes after loopbreaking)-findLoopBreakers func ex (Graph g ln kv fn) = ans where-    scc = Data.Graph.scc g-    ans = f g scc [] [] where-        f g (Node v []:sccs) fs lb-            | v `elem` g ! v = let ng = (fmap (List.delete v) g) in  f ng (Data.Graph.scc ng) [] (v:lb)-            | otherwise = f g sccs (v:fs) lb--        f g (n:_) fs lb = f ng (Data.Graph.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 (List.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---sccGroups :: Graph n k -> [[n]]-sccGroups g = map fromScc (Util.Graph.scc g)--scc :: Graph n k -> [Either n [n]]-scc (Graph g ln kv fn) = map decode forest where-    forest = Data.Graph.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 k -> Forest n-sccForest (Graph g ln kv fn) = map (fmap ln) forest where-    forest = Data.Graph.scc g--dff :: Graph n k -> Forest n-dff (Graph g ln kv fn) = map (fmap ln) forest where-    forest = Data.Graph.dff g--dfs :: Graph n k -> [k] -> Forest n-dfs (Graph g ln kv fn) ks = map (fmap ln) forest where-    forest = Data.Graph.dfs g [ v | Just v <- map kv ks]--components :: Graph n k -> [[n]]-components (Graph g ln kv fn) = map decode forest where-    forest = Data.Graph.components g-    decode n = dec n []-    dec (Node v ts) vs = ln v:foldr dec vs ts---reachable :: Graph n k -> [k] -> [n]-reachable (Graph g ln kv _) ns = map ln $ snub $  concatMap (Data.Graph.reachable g) gs where-    gs = [ v | Just v <- map kv ns]--topSort :: Graph n k -> [n]-topSort (Graph g ln _ _) = map ln $ Data.Graph.topSort g--cyclicNodes :: Graph n k -> [n]-cyclicNodes g = concat [ xs | Right xs <- Util.Graph.scc g]-
− src/Util/Graphviz.hs 
@@ -1,84 +0,0 @@--- | Simple graphviz output.-module Util.Graphviz(-    Orient(..),-    graphviz, graphviz'-) where--import Data.Graph.Inductive.Graph-import 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 
@@ -1,96 +0,0 @@-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 
@@ -1,56 +0,0 @@-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--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 (Map.singleton a 1)-insert a (Histogram m) = Histogram (Map.insertWith (+) a 1 m)-find a (Histogram m) = Map.findWithDefault 0 a m-toList (Histogram m) = Map.toAscList m-satisfy f (Histogram m) = [ a | (a,i) <- Map.toAscList m, f i ]-satisfyKey f (Histogram m) = [ (a,i) | (a,i) <- Map.toAscList m, f i ]-filter f (Histogram m) = Histogram (Map.filterWithKey f m)-keys (Histogram m) = Map.keys m-elems (Histogram m) = Map.elems m-map f (Histogram m) = Histogram $ Map.fromList [ (f k,i) | (k,i) <- Map.toList m ]-mapM f (Histogram m) = do-        ds <- sequence [ do f k >>= return . flip (,) i  | (k,i) <- Map.toList m ]-        return $ Histogram (Map.fromList ds)-mapM_ f (Histogram m) = sequence_ [ do f k >>= return . flip (,) i  | (k,i) <- Map.toList m ]-fromList :: Ord a => [a] -> Histogram a-fromList xs = foldr insert empty xs-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 
@@ -1,28 +0,0 @@---- Useful instances that don't belong anywhere else.-module Util.Inst() where--import Control.Monad.Identity-import qualified Data.Map as Map-import qualified Data.IntMap as IM-import Data.Monoid-import List-import Data.Traversable---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---instance Traversable IM.IntMap where-    traverse f mp = (IM.fromAscList . Map.toAscList) `fmap`  (traverse f . Map.fromAscList . IM.toAscList $ mp)
− src/Util/IntBag.hs 
@@ -1,1328 +0,0 @@-{-# 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.Int---import qualified Data.IntSet as IntSet-import Data.Monoid (Monoid(..))---import Data.Typeable---import Data.Foldable (Foldable(foldMap))---#if __GLASGOW_HASKELL__---import Text.Read---import Data.Generics.Basics---import Data.Generics.Instances-#endif--import GHC.Exts ( Word(..), Int(..), shiftRL# )-----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 :: 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 
@@ -1,154 +0,0 @@-module Util.Interact(-    Interact(..),-    InteractCommand(..),-    beginInteraction,-    runInteraction,-    runInteractions,-    emptyInteract-) where-import IO-import Char-import List-import qualified Data.Map as Map-import Control.Monad.Identity-import Control.Monad.Trans-import System-import System.Console.Haskeline-import System.Directory-import GenUtil---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"),-    (":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-    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,-    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) -> System.system 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-            [":cd"] -> IO.catch (setCurrentDirectory arg) (\_ -> putStrLn $ "Could not change to directory: " ++ arg) >> return act-            [":pwd"] -> (IO.catch 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 <- IO.catch (readFile arg) (\_ -> putStrLn ("Could not read file: " ++ arg) >> return "")-                act <- runInteractions act { interactEcho = True } (lines fc)-                return act { interactEcho = False }-            [":execfile!"] -> do-                fc <- IO.catch (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 = runInputT defaultSettings (loop act)-    where loop act = do s <- getInputLine (thePrompt act)-                        case s of-                          Nothing -> outputStrLn "Bye!" >> liftIO exitSuccess-                          Just cs | all isSpace cs -> return ()-                          Just s -> liftIO (runInteraction act s) >>= loop
− src/Util/NameMonad.hs 
@@ -1,95 +0,0 @@-module Util.NameMonad(NameMonad(..), GenName(..), NameMT, runNameMT, runNameMT', freeNames) where---- This may be horrid overdesign. I broke several principles I usually use to--- prevent ones natural tendancy to overdesign.--import qualified Data.Set as Set-import Control.Monad.State-import Control.Monad.Trans---- | 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--}-{--instance GenName Id where-    genNames i = map unnamed [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 + Set.size bound))--
− src/Util/Once.hs 
@@ -1,101 +0,0 @@---- | 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 
@@ -1,19 +0,0 @@-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/RWS.hs 
@@ -1,147 +0,0 @@-{-# LANGUAGE BangPatterns, UnboxedTuples #-}---- 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.Reader ( MonadReader(..), asks )-import Control.Monad.Writer ( MonadWriter(..), censor, WriterT(..) )-import Control.Monad.State-import Data.Monoid----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 
@@ -1,43 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--module Util.ReaderWriter(ReaderWriter(),runReaderWriter) where--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 
@@ -1,42 +0,0 @@---- | extend Data.Set with relation operations--module Util.Relation(module Util.Relation, module Set) where--import Data.Set as Set hiding(map)-import qualified Data.Set as Set (map)--type Rel a b = Set (a,b)---domain :: (Ord a,Ord b) => Rel a b -> Set a-domain r = Set.map fst r--range :: (Ord a,Ord b) => Rel a b -> Set b-range r = Set.map snd r--flipRelation :: (Ord a, Ord b) => Rel a b -> Rel b a-flipRelation = Set.map (\ (x,y) -> (y,x))--restrictDomain :: (Ord a, Ord b) => (a -> Bool) -> Rel a b -> Rel a b-restrictDomain f r = Set.filter (f . fst) r--restrictRange :: (Ord a, Ord b) => (b -> Bool) -> Rel a b -> Rel a b-restrictRange f r = Set.filter (f . snd) r---mapDomain :: (Ord a, Ord b, Ord c) => (a -> c) -> Rel a b -> Rel c b-mapDomain f r = Set.map (\ (x,y) -> (f x,y)) r--mapRange :: (Ord a, Ord b, Ord c) => (b -> c) -> Rel a b -> Rel a c-mapRange f r = Set.map (\ (x,y) -> (x,f y)) r--partitionDomain f r = Set.partition (f . fst) r--partitionRange f r = Set.partition (f . snd) r--applyRelation :: (Ord a, Ord b) => Rel a b -> a -> [b]-applyRelation r a = Prelude.map snd (toList $ restrictDomain (== a) r)--toRelationList :: (Ord a, Ord b) => Rel a b -> [(a,[b])]-toRelationList rel = [ (x, applyRelation rel x) | x <- toList (domain rel)]
− src/Util/SameShape.hs 
@@ -1,45 +0,0 @@-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 
@@ -1,124 +0,0 @@----------------------------------------------------------------------------------{-| 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()-import Control.Monad.Writer as W--{---------------------------------------------------------------------  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)----instance Monoid (Seq.Seq a) where---    mempty = Seq.empty---    mappend = (Seq.<>)--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 
@@ -1,213 +0,0 @@-module Util.SetLike(-    EnumSet(),-    (\\),-    notMember,-    mnotMember,-    minsert,-    msingleton,-    intersects,-    mfindWithDefault,-    SetLike(..),-    ModifySet(..),-    MapLike(..),-    BuildSet(..)-    ) where---import Data.Monoid-import Data.Typeable-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import qualified Data.Map as M-import qualified Data.Set as S--import Util.HasSize--infixl 9 \\ ----m1 \\ m2 = difference m1 m2--class (HasSize s,IsEmpty s) => SetLike s where-    difference :: s -> s -> s-    intersection :: s -> s -> s-    disjoint :: s -> s -> Bool-    isSubsetOf :: s -> s -> Bool--    union :: s -> s -> s-    unions :: [s] -> s-    sempty :: s--    disjoint x y = isEmpty (x `intersection` y)-    isSubsetOf x y = size x <= size y && (size (x `intersection` y) == size x)-    unions ss = foldr union sempty ss----- you can't pull values out of the set with this, as it might store the--- essence of a data type--class SetLike s => BuildSet t s | s -> t where-    fromList :: [t] -> s-    fromDistinctAscList :: [t] -> s-    insert :: t -> s -> s-    singleton :: t -> s--    singleton t = fromDistinctAscList [t]-    fromDistinctAscList = fromList--class BuildSet t s => ModifySet t s | s -> t where-    toList :: s -> [t]-    delete :: t -> s -> s-    member :: t -> s -> Bool-    sfilter :: (t -> Bool) -> s -> s--notMember x t = not $ member x t-mnotMember x t = not $ mmember x t--intersects x y = not $ disjoint x y-----  int set--instance SetLike IS.IntSet where-    difference = IS.difference-    intersection = IS.intersection-    isSubsetOf = IS.isSubsetOf-    union      = IS.union-    unions     = IS.unions-    sempty      = IS.empty--instance BuildSet Int IS.IntSet where-    fromList xs = IS.fromList xs-    fromDistinctAscList xs = IS.fromDistinctAscList xs-    insert x s = IS.insert x s-    singleton x = IS.singleton x--instance ModifySet Int IS.IntSet where-    toList s   = IS.toList s-    delete x s = IS.delete x s-    member x s = IS.member x s-    sfilter    = IS.filter---- normal set--instance Ord a => SetLike (S.Set a) where-    difference = S.difference-    intersection = S.intersection-    isSubsetOf = S.isSubsetOf-    union      = S.union-    unions     = S.unions-    sempty      = S.empty--instance Ord a => BuildSet a (S.Set a) where-    fromList xs = S.fromList xs-    fromDistinctAscList xs = S.fromDistinctAscList xs-    insert x s = S.insert x s-    singleton x = S.singleton x--instance Ord a => ModifySet a (S.Set a) where-    toList s   = S.toList s-    member x s = S.member x s-    delete x s = S.delete x s-    sfilter    = S.filter---- maps--instance SetLike (IM.IntMap a) where    -- SIC-    difference = IM.difference-    intersection = IM.intersection-    union      = IM.union-    unions     = IM.unions-    sempty     = IM.empty---instance BuildSet (Int,a) (IM.IntMap a) where-    fromList xs = IM.fromList xs-    fromDistinctAscList xs = IM.fromDistinctAscList xs-    insert (k,v) s = IM.insert k v s-    singleton (k,v) = IM.singleton k v---instance Ord a => SetLike (M.Map a b) where-    difference = M.difference-    intersection = M.intersection-    union      = M.union-    unions     = M.unions-    sempty     = M.empty--instance Ord a => BuildSet (a,b) (M.Map a b) where-    fromList xs = M.fromList xs-    fromDistinctAscList xs = M.fromDistinctAscList xs-    insert (k,v) s = M.insert k v s-    singleton (k,v) = M.singleton k v--minsert :: BuildSet (k,v) s => k -> v -> s -> s-minsert k v s = insert (k,v) s--msingleton :: BuildSet (k,v) s => k -> v -> s-msingleton k v = singleton (k,v)---class SetLike m => MapLike k v m | m -> k v where-    mdelete :: k -> m -> m-    mmember :: k -> m -> Bool-    mlookup :: k -> m -> Maybe v-    melems :: m -> [v]-    massocs :: m -> [(k,v)]-    mkeys :: m -> [k]-    mmapWithKey :: (k -> v -> v) -> m -> m-    mfilter :: (v -> Bool) -> m -> m-    mfilterWithKey :: (k -> v -> Bool) -> m -> m-    munionWith :: (v -> v -> v) -> m -> m -> m-    mpartitionWithKey :: (k -> v -> Bool) -> m -> (m,m)--    mkeys = map fst . massocs-    melems = map snd . massocs--instance MapLike Int a (IM.IntMap a) where-    mdelete = IM.delete-    mmember = IM.member-    mlookup k m = IM.lookup k m-    melems = IM.elems-    mkeys = IM.keys-    massocs = IM.toList-    mfilter = IM.filter-    mmapWithKey = IM.mapWithKey-    mfilterWithKey = IM.filterWithKey-    munionWith = IM.unionWith-    mpartitionWithKey = IM.partitionWithKey--instance Ord k => MapLike k v (M.Map k v) where-    mdelete = M.delete-    mmember = M.member-    mlookup = M.lookup-    melems = M.elems-    mkeys = M.keys-    massocs = M.toList-    mfilter = M.filter-    mmapWithKey = M.mapWithKey-    mfilterWithKey = M.filterWithKey-    munionWith = M.unionWith-    mpartitionWithKey = M.partitionWithKey--mfindWithDefault d k m = case mlookup k m of-    Nothing -> d-    Just x -> x---- EnumSet--newtype EnumSet a = EnumSet IS.IntSet-    deriving(Typeable,Monoid,SetLike,HasSize,Eq,Ord,IsEmpty)--instance Enum a => BuildSet a (EnumSet a) where-    fromList xs = EnumSet $ IS.fromList (map fromEnum xs)-    fromDistinctAscList xs = EnumSet $ IS.fromDistinctAscList (map fromEnum xs)-    insert x (EnumSet s) = EnumSet $ IS.insert (fromEnum x) s-    singleton x = EnumSet $ IS.singleton (fromEnum x)--instance Enum a => ModifySet a (EnumSet a) where-    toList (EnumSet s) = map toEnum $ toList s-    member x (EnumSet s) = IS.member (fromEnum x) s-    delete x (EnumSet s) = EnumSet $ IS.delete (fromEnum x) s-    sfilter f (EnumSet s) = EnumSet $ IS.filter (f . toEnum)  s--
− src/Util/UnionFind.hs 
@@ -1,96 +0,0 @@-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 Monad(when,liftM)--data Element w a = Element a {-# UNPACK #-} !Int {-# 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 <- liftM hashUnique 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 
@@ -1,352 +0,0 @@-module Util.UnionSolve(-    C(),-    solve,-    Fixable(..),-    Topped(..),-    Result(..),-    islte,isgte,equals-    ) where--import Data.List(intersperse)-import Data.Monoid-import qualified Data.Set as Set-import qualified Data.Map as Map-import Util.UnionFind as UF---- simple constraint solver based on ideas from 'Once upon a polymorphic type' paper.---class Fixable a where-    isBottom :: a -> Bool-    isTop :: a -> Bool-    join :: a -> a -> a-    meet :: a -> a -> a-    eq :: a -> a -> Bool--    lte :: a -> a -> Bool-    showFixable :: a -> String-    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-newtype C l v = C ([CL l v] -> [CL l v])--instance Monoid (C l v) where-    mempty = C id-    mappend (C a) (C b) = C (a . b)--data CL l v = (Either v l) `Clte` (Either v l) | (Either v l) `Cset` (Either v l)-    deriving(Eq,Ord)---instance (Show e,Show l) => Show (C l e) where-    showsPrec _ (C xs) = showString "" . foldr (.) id (intersperse (showString "\n") (map shows (xs []))) . showString "\n"--seither (Left x) = shows x-seither (Right x) = shows x--instance (Show e,Show l) => Show (CL l e) where-    showsPrec _ (x `Clte` y) = seither x . showString " <= " . seither y-    showsPrec _ (x `Cset` l) = seither x . showString " := " . seither l---- basic constraints-islte,isgte,equals :: Either v l -> Either v l -> C l v-islte  x y = C ((x `Clte` y):)-isgte  x y = islte y x-equals x y = C ((x `Cset` y):)---- 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--data Result l a = ResultJust a 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-----collectVars (Cset x y:xs) = x:y:collectVars xs-collectVars (Clte x y:xs) = x:y:collectVars xs-collectVars [] = []--data Direction = Lower | Upper--------- (C l v) represents a constraint (or set of constraints) that confine the--- variables 'v' to within specific values of 'l'------{-# 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 (C csp) = do-    let vars = Set.fromList [ x | Left x <- collectVars cs]-        cs = csp []-    ufs <- flip mapM (Set.toList vars) $ \a -> do-        uf <- UF.new (Ri Nothing mempty Nothing mempty) a-        return (a,uf)-    let prule (Left x `Clte` Left y) = ans where-            Just xe = Map.lookup x umap-            Just ye = Map.lookup y umap-            ans = do-                xe <- UF.find xe-                ye <- UF.find ye-                xe `lessThenOrEqual` ye-        prule (Right x `Clte` Left y) = ans where-            Just ye = Map.lookup y umap-            ans = do-                ye <- UF.find ye-                x `lessThen` ye-        prule (Left x `Clte` Right y) = ans where-            Just xe = Map.lookup x umap-            ans = do-                xe <- UF.find xe-                y `greaterThen` xe-        prule (Right v `Cset` Left x) = prule (Left x `Cset` Right v)-        prule (Left x `Cset` Right v) = ans where-            Just xe = Map.lookup x umap-            ans = do-                xe <- UF.find xe-                xe `setValue` v-        prule (Left x `Cset` Left y) = ans where-            Just xe = Map.lookup x umap-            Just ye = Map.lookup y umap-            ans = do-                xe <- UF.find xe-                ye <- UF.find ye-                xe `lessThenOrEqual` ye-                xe <- UF.find xe-                ye <- UF.find ye-                ye `lessThenOrEqual` xe-        -- handle constant cases, just check if valid, and perhaps report error-        prule (Right x `Cset` Right y)-            | x `eq` y = return ()-            | otherwise = fail $ "equality of two different values" ++ show (x,y)-        prule (Right x `Clte` Right y)-            | x `lte` y = return ()-            | otherwise = fail $ "invalid constraint: " ++ show x ++ " <= " ++ show y-        setValue xe v = do-            putLog $ "Setting value of " ++ show (fromElement xe) ++ " to " ++ show v-            xw <- getW xe-            case xw of-                R c | c `eq` v -> return ()-                    | otherwise -> fail $ "UnionSolve: equality constraints don't match " ++ show (c,v)-                Ri ml lb mu ub | testBoundLT ml v && testBoundGT mu v -> do-                    mapM_ (v `greaterThen`) (Set.toList lb)-                    mapM_ (v `lessThen`)    (Set.toList ub)-                    updateW (const (R v)) xe-        nem Nothing Nothing = False-        nem (Just x) (Just y) = not (x `eq` y)-        nem _ _ = True-        getBounds Lower (Ri _ lb _ _) = lb-        getBounds Upper (Ri _ _ _ ub) = ub-        getBounds _ _ = Set.empty-        testBoundLT Nothing _ = True-        testBoundLT (Just x) y = x `lte` y-        testBoundGT Nothing _ = True-        testBoundGT (Just x) y = y `lte` x-        v `greaterThen` xe = do-            putLog $ "make sure " ++ show (fromElement xe) ++ " is less than " ++ show v-            xw <- UF.getW xe-            case xw of-                R c | c `lte` v -> return ()-                    | otherwise -> fail $ "UnionSolve: greaterThen " ++ show (v,c)-                Ri _ _ (Just n) _ | n `lte` v -> return ()-                Ri ml lb mu ub | testBoundLT ml v -> do-                    doUpdate (Ri ml lb (mmeet (Just v) mu) ub) xe-                    mapM_ (greaterThen v) (Set.toList lb)-                               | otherwise -> fail $ "UnionSolve: testBoundLT " ++ show (ml,v)-        v `lessThen` xe = do-            putLog $ "make sure " ++ show (fromElement xe) ++ " is greater than " ++ show v-            xw <- getW xe-            case xw of-                R c | v `lte` c -> do return ()-                    | otherwise -> fail $ "UnionSolve: lessThen " ++ show (v,c)-                Ri (Just n) _ _ _ |  v `lte` n -> do return ()-                Ri ml lb mu ub | testBoundGT mu v -> do-                    doUpdate (Ri (mjoin (Just v) ml) lb mu ub) xe-                    mapM_ (lessThen v) (Set.toList ub)-                               | otherwise -> fail $ "UnionSolve: testBoundGT " ++ show (mu,v)-        --checkRS :: R l a -> RS l a -> IO ()-        checkRS (Ri (Just l) _ (Just u) _) xe | l `eq` u = do-            putLog $ "Boxed in value of " ++ show (fromElement xe) ++ " being set to " ++ show l-            setValue xe 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)-            setValue xe l-        checkRS (Ri  _ _ (Just u) _) xe | isBottom u = do-            putLog $ "Going down: " ++ show (fromElement xe)-            setValue xe u-        checkRS r xe = return ()-        xe `lessThenOrEqual` ye | xe == ye = return ()-        xe `lessThenOrEqual` ye = do-            xw <- UF.getW xe-            case xw of-                R v -> (v `lessThen` ye)-                Ri xml xlb xmu xub -> do-                    xlb <- finds xlb-                    if ye `Set.member` xub then return () else do-                    xub <- finds xub-                    if ye `Set.member` xlb then equal xe ye  else do-                    yw <- UF.getW ye-                    case yw of-                        R v -> (v `greaterThen` xe)-                        Ri yml ylb ymu yub -> do-                            xlb <- finds xlb-                            if xe `Set.member` ylb then return () else do-                            xub <- finds xub-                            if xe `Set.member` yub then equal xe ye  else do-                            updateW (const (Ri xml xlb (mmeet ymu xmu) (Set.delete xe $ Set.insert ye xub))) xe-                            updateW (const (Ri (mjoin yml xml) (Set.delete ye $ Set.insert xe ylb) ymu yub)) ye-                            w <- getW xe-                            checkRS w xe-                            w <- getW ye-                            checkRS w ye-        doUpdate r xe = do-            updateW (const r) xe-            checkRS r xe-        equal xe ye | xe == ye = return ()-        equal xe ye = do-            xw <- getW xe-            yw <- getW ye-            union const xe ye-            xe <- find xe-            case (xw,yw) of-                (Ri xml xlb xmu xub,Ri yml ylb ymu yub) -> do-                    let nml = xml `mjoin` yml-                        nmu = xmu `mmeet` ymu-                    nlb <- finds (xlb `mappend` ylb)-                    nub <- finds (yub `mappend` xub)-                    doUpdate (Ri nml (Set.delete xe nlb) nmu (Set.delete xe nub)) 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)-        finds set = fmap Set.fromList $ mapM UF.find (Set.toList set)-        umap = Map.fromList ufs-    mapM_ prule cs-    rs <- flip mapM ufs $ \ (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)---------------------------- useful instances----------------------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 = (<=)---- bottom is zero and the 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')----- 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 = Top | Only a-    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 (join a b)-    join Top b = Top-    join a Top = Top-    join (Only a) (Only b) = Only (meet a b)-    lte _ Top = True-    lte Top _ = False-    lte (Only x) (Only y) = x `lte` y-----
− src/Util/UniqueMonad.hs 
@@ -1,54 +0,0 @@-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.Writer-import Control.Monad.Identity---- FIXME: We should never rely on IO to generate unique ids.-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 
@@ -1,11 +0,0 @@-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 
@@ -1,72 +0,0 @@-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/arch/generic.arch 
@@ -1,75 +0,0 @@-arch_generic = [-  PrimType {-    primTypeName = "uint32_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "HsChar",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "int8_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "int16_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "int32_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "int64_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "uint8_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "uint16_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "uint32_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "uint64_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "char",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "void",-    primTypeIsSigned = False,-    primTypeType = PrimTypeVoid,-    primTypeAlignmentOf = 0,-    primTypeSizeOf = 0 }-  ]-
− src/arch/i686.arch 
@@ -1,177 +0,0 @@-arch_i686 = [-  PrimType {-    primTypeName = "uint32_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "HsChar",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "int",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "intmax_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "int8_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "int16_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "int32_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "int64_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "intmax_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "intptr_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "unsigned int",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "uint8_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "uint16_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "uint32_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "uint64_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "uintmax_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "uintptr_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "float",-    primTypeIsSigned = True,-    primTypeType = PrimTypeFloating,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "double",-    primTypeIsSigned = True,-    primTypeType = PrimTypeFloating,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "HsPtr",-    primTypeIsSigned = False,-    primTypeType = PrimTypePointer,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "HsFunPtr",-    primTypeIsSigned = False,-    primTypeType = PrimTypePointer,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "char",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "short",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "int",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "unsigned int",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "size_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "wchar_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "wint_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "void",-    primTypeIsSigned = False,-    primTypeType = PrimTypeVoid,-    primTypeAlignmentOf = 0,-    primTypeSizeOf = 0 }-  ]-
− src/arch/x86_64.arch 
@@ -1,177 +0,0 @@-arch_x86_64 = [-  PrimType {-    primTypeName = "uint32_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "HsChar",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "int",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "intmax_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "int8_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "int16_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "int32_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "int64_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "intmax_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "intptr_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "unsigned int",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "uint8_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "uint16_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "uint32_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "uint64_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "uintmax_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "uintptr_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "float",-    primTypeIsSigned = True,-    primTypeType = PrimTypeFloating,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "double",-    primTypeIsSigned = True,-    primTypeType = PrimTypeFloating,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "HsPtr",-    primTypeIsSigned = False,-    primTypeType = PrimTypePointer,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "HsFunPtr",-    primTypeIsSigned = False,-    primTypeType = PrimTypePointer,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "char",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 1,-    primTypeSizeOf = 1 },-  PrimType {-    primTypeName = "short",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 2,-    primTypeSizeOf = 2 },-  PrimType {-    primTypeName = "int",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "unsigned int",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "size_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 8,-    primTypeSizeOf = 8 },-  PrimType {-    primTypeName = "wchar_t",-    primTypeIsSigned = True,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "wint_t",-    primTypeIsSigned = False,-    primTypeType = PrimTypeIntegral,-    primTypeAlignmentOf = 4,-    primTypeSizeOf = 4 },-  PrimType {-    primTypeName = "void",-    primTypeIsSigned = False,-    primTypeType = PrimTypeVoid,-    primTypeAlignmentOf = 0,-    primTypeSizeOf = 0 }-  ]-