packages feed

lhc (empty) → 0.6.20081127

raw patch · 193 files changed

+48637/−0 lines, 193 filesdep +ansi-terminaldep +ansi-wl-pprintdep +arraysetup-changed

Dependencies added: ansi-terminal, ansi-wl-pprint, array, base, binary, bytestring, containers, derive, directory, fgl, filepath, graphviz, haskeline, haskell98, mtl, old-time, pretty, pureMD5, random, regex-compat, stringtable-atom, syb, unix, utf8-string, zlib

Files

+ COPYING view
@@ -0,0 +1,350 @@+All or most of the source files in this distribution refer to this+file for copyright and warranty information.  This file should be+included whenever those files are redistributed.++This software is free software: you can redistribute it and/or modify+it under the terms of the GNU General Public License, version 2, as+published by the Free Software Foundation or any later version at your option.+That license is reproduced below.+++		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++			    Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++			    NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++		     END OF TERMS AND CONDITIONS++	    How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software; you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation; either version 2 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program; if not, write to the Free Software+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year  name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data/HsFFI.h view
@@ -0,0 +1,41 @@+/* 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/ViaGhc.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-implicit-prelude #-}+module Main(main) where++import GHC.Int+import GHC.Word+import GHC.IOBase+import GHC.Prim+import GHC.Base+import GHC.Ptr+import GHC.Err++type World__ = State# RealWorld+type Array__ a = Array# a+type MutArray__ a = MutableArray# RealWorld a+type Ref__ a = MutVar# RealWorld a++type Nothing = ()++theNothing :: Nothing+theNothing = ()++type JIO a = World__ -> (# World__, a #)++main :: IO ()+main = IO $ \rw -> case theRealMain rw of rw' -> (# rw', () #)++unPtr :: Ptr a -> Addr#+unPtr ptr = case ptr of+    Ptr addr -> addr++unFunPtr :: FunPtr a -> Addr#+unFunPtr ptr = case ptr of+    FunPtr addr -> addr++fromBool :: Bool -> Int#+fromBool b = case b of+    False -> 0#+    True -> 1#++gteChar# a b = gtChar# a b || eqChar# a b+lteChar# a b = ltChar# a b || eqChar# a b++plusAddr__ :: Addr# -> Addr# -> Addr#+plusAddr__ a1 a2 = plusAddr# a1 (addr2Int# a2)++alloca__ :: Int# -> (Addr# -> JIO a) -> JIO a+alloca__ size action s =+     case newPinnedByteArray# size s      of { (# s, mbarr# #) ->+     case unsafeFreezeByteArray# mbarr# s of { (# s, barr#  #) ->+     case action (byteArrayContents# barr#) s of { (# s, r #) ->+     case touch# barr# s of { s -> (# s, r #) }+     }}}++word2Char__ x = chr# (word2Int# x)+char2Word__ x = int2Word# (ord# x)+addr2Word__ x = int2Word# (addr2Int# x)+word2Addr__ x = int2Addr# (word2Int# x)++convertString :: [Char] -> ListTCon Char+convertString [] = lhc_EmptyList+convertString (x:xs) = lhc_Cons x (convertString xs)++{-+error__ :: Addr# -> a+error__ s = unsafePerformIO $ do+    error_show s+    error_exit (I# 255#)++errorInt__ :: Addr# -> Int#+errorInt__ s = seq (unsafePerformIO $ do+    error_show s+    error_exit (I# 255#)) 0#++errorWord__ :: Addr# -> Word#+errorWord__ s = seq (unsafePerformIO $ do+    error_show s+    error_exit (I# 255#)) (int2Word# 0#)++errorAddr__ :: Addr# -> Addr#+errorAddr__ s = seq (unsafePerformIO $ do+    error_show s+    error_exit (I# 255#)) (int2Addr# 0#)+foreign import ccall unsafe "puts" error_show :: Ptr a -> IO ()+foreign import ccall unsafe "exit" error_exit :: Int -> IO a+ -}++{-# NOINLINE newWorld__ #-}+newWorld__ :: a -> World__+newWorld__ a = case lazy a of+    _ -> realWorld#++theRealMain :: World__ -> World__+
+ data/names.txt view
@@ -0,0 +1,128 @@++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_++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 view
@@ -0,0 +1,36 @@++++[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 view
@@ -0,0 +1,4 @@+m4_changequote({{,}})+m4_changecom({-,-})++m4_define(ONCE,{{m4_ifdef(done-$1,{{m4_dnl}},{{m4_define(done-$1,1)$1}})}})
+ data/primitives.txt view
@@ -0,0 +1,40 @@+# 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 view
@@ -0,0 +1,26 @@+# 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 view
@@ -0,0 +1,143 @@++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 view
@@ -0,0 +1,252 @@++#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);+                assert(dhead >= &_start && dhead < &_end);+                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 view
@@ -0,0 +1,144 @@++// 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)++extern void _start,_end;++#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++#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++#elif _LHC_GC == _LHC_GC_JGC++#error "jgc not supported yet."++#endif++++
+ data/rts/lhc_rts_header.h view
@@ -0,0 +1,80 @@++// 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_JGC      1+#define _LHC_GC_BOEHM 2+++#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 view
@@ -0,0 +1,67 @@+#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 view
@@ -0,0 +1,4714 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+module FrontEnd.HsParser (parse, parseHsStmt) where++import C.FFI+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) }+	) `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) }+	)}++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 }+	) `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 }+	) `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.cabal view
@@ -0,0 +1,79 @@+cabal-version:       >= 1.2+name:                lhc+version:             0.6.20081127+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+category:            Compiler+license:             GPL+license-file:        COPYING+author:              John Meacham, David Himmelstrup+maintainer:          lemmih@gmail.com+homepage:            http://lhc.seize.it/+build-type:          Simple+Extra-Source-Files:  src/arch/generic.arch, src/arch/i686.arch, src/arch/x86_64.arch+data-dir:            data+data-files:          HsFFI.h names.txt operators.txt prelude.m4 primitives.txt props.txt wsize.h ViaGhc.hs+                     rts/lhc_rts.c rts/lhc_rts2.c rts/lhc_rts_alloc.c rts/lhc_rts_header.h ++flag base4+flag hpc+  default:            False+flag threaded+  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, haskeline, 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+++ if flag(base4)+  build-depends:      base >= 4 && < 5, syb+ else+  build-depends:      base >= 3 && < 4+  Extensions:         PatternSignatures+ if flag(threaded)+  ghc-options:        -threaded++ Other-modules:+  CharIO, FindFixpoint, FlagOpts, Interactive, 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.Binary Name.Id Name.Name Name.Names Name.VConsts+  Support.Tuple Support.CFF Support.FreeVars Support.CanType Support.ShowTable+  Support.Tickle Support.Transform Support.Unparse Support.MapBinaryInstance 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.TrueSet+  Util.UnionFind Util.UnionSolve Util.UniqueMonad Util.VarName Util.Util LHCVersion
+ src/C/Arch.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE CPP, BangPatterns #-}+module C.Arch(+    ArchInfo(),+    archGetPrimInfo,+    archInfo,+    archOpTy,+    stringToOpTy,+    genericArchInfo,+    determineArch,+    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)+        (backendGhc,specs') | ("ghc":rs) <- specs = (True,rs)+                            | ("grin":rs) <- specs = (False,rs)+                            | ("fgrin":rs) <- specs = (False,rs)+                            | otherwise = (fopts FO.ViaGhc,specs)+        (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 (backendGhc,cpu,bits) of+            (True,!_,32) -> ("ghc-" ++ show bits,arch_i686,[])+            (True,!_,64) -> ("ghc-" ++ show bits,arch_x86_64,[])+            (_,"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 (backendGhc,fn,mp,opt)++arch_error =  error $ "\nunknown architecture, supported architectures are:\n" ++ show available_archs+++++
+ src/C/FFI.hs view
@@ -0,0 +1,53 @@+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 view
@@ -0,0 +1,888 @@++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(nest,(<$$>))+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+    cpr = iw `Set.union` Set.insert cChar (Set.fromList [ a | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) <- Map.assocs tmap, a == a', isJust (good s) ])+    iw = if fopts FO.FullInt then Set.empty else Set.fromList [cInt, cWord]+    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 {" <$$> nest 4 (P.vcat (punctuate P.comma $ enums)) <$$> text "};"+        where+            f t n = tshow t <> text " = " <> tshow (n :: Int)+            enums =  map (uncurry f) (Map.toList wenum) ++ (zipWith f (Set.toList (Set.map nodeTagName ts)) [0 ..])+    go = do+        funcs <- liftM concat $ flip mapM (grinFuncs grin) $ \(a,l) -> do+                    convertFunc (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 = e+        am ~(NodeC t2 _) e = 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' <- liftM (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 view
@@ -0,0 +1,687 @@+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,nest,(<$$>))+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 '{', nest 4 s, char '}']+    draw (SIf exp thn els) = do+        exp <- draw exp+        thn <- subBlockBody thn+        els <- subBlockBody els+        return $ text "if" <+> parens exp <+> lbrace <$> nest 4 thn <$> rbrace <+> text "else" <+> lbrace <$> nest 4 els <$> rbrace+    draw (SSwitch e ts) = text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where+        sc (Just x,ss) = do ss <- draw (SBlock ss); x <- draw x; return $ text "case" <+> x <> char ':' <$$> nest 4 (ss <$$> text "break;")+        sc (Nothing,ss) = do ss <- draw (SBlock ss); return $ text "default:"  <$$>  ( nest 4 ss <$$> text "break;")+        md = if any isNothing (fsts ts) then empty else text "default: 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 :: Int -> 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 <$> nest 4 body <$> rbrace++++data Function = F {+    functionName :: Name,+    functionReturnType :: Type,+    functionArgs :: [(Name,Type)],+    functionOptions :: [FunctionOpts],+    functionBody :: Statement+    }++data FunctionOpts = Public | Attribute String+    deriving(Eq)++function :: Name -> Type -> [(Name,Type)] -> [FunctionOpts] -> Statement -> Function+function n t as o s = F n t as o s+++drawFunction f = do+    frt <- draw (functionReturnType f)+    cenv <- ask+    let env = cenv { envUsedLabels = ul, envInScope = Set.fromList $ fsts (functionArgs f) } where+        ul = Set.fromList $ Seq.toList $ Seq.foldMap (travCollect stmtMapStmt g) stseq+        St stseq = functionBody f+        g (SGoto n) = Seq.singleton n+        g s = mempty+        vcmp (n,t@(TB _ b)) = (not b,n)+        vcmp (n,t) = (True,n)+    (body,uv) <- local (const env) $ listen (draw (functionBody f))+    uv' <- forM [ (x,t) | (x,t) <- snubUnder vcmp uv, x `notElem` fsts (functionArgs f)] $ \ (n,t) -> do+        t <- draw t+        return $ t <+> tshow n <> semi+    name <- draw (functionName f)+    fas <- forM (functionArgs f) $ \ (n,t) -> do+        n <- draw n+        t <- draw t+        return $ t <+> n+    let fas' = if null fas then [text "void"] else fas+        proto = static <+> frt <+> name <> tupled fas' <> parms <> semi+        proto' = static <+> frt <> parms <$$> name <> tupled fas'+        static = if Public `elem` functionOptions f then empty else text "static"+        parms = char ' ' <> hsep [ text s | Attribute s <- functionOptions f]+    return (proto, proto' $+$ lbrace $+$ nest 8 (vcat uv' <$$> body) $+$ rbrace)++-- types+anonStructType :: [Type] -> Type+anonStructType ts = TAnon ts++basicType :: String -> Type+basicType s = TB s False++-- | a basic type the garbage collector might want to follow, guarenteed to be+-- the size of a pointer.+basicGCType :: String -> Type+basicGCType s = TB s True++structType :: Name -> Type+structType n = TNStruct n++ptrType :: Type -> Type+ptrType t = TPtr t++funPtrType :: Type -> [Type] -> Type+funPtrType r as = TFunPtr r as++-- type constants+voidStarType :: Type+voidStarType = ptrType voidType++voidType :: Type+voidType = basicType "void"++++class Annotate e where+    annotate :: String -> e -> e++instance Annotate Statement where+    --annotate c s@(SD si _) = SD si ((text "/* " <> text c <> text " */") <$> draw s)+    annotate c s = sd (text "/* " <> text c <> text " */") `mappend` s+++mangleIdent xs =  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 <$$> nest 4 (vcat $ (if structureNeedsDiscriminator s  then text "what_t what;" else empty):ts') <$$> rbrace <> semi+++line = text ""+vsep xs = vcat $ intersperse line xs+++instance Show Expression where+    show e = renderG e++renderG x = 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 view
@@ -0,0 +1,184 @@+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 view
@@ -0,0 +1,26 @@+{-# 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 __GLASGOW_HASKELL__ >= 610+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 view
@@ -0,0 +1,25 @@+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 view
@@ -0,0 +1,388 @@+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 view
@@ -0,0 +1,197 @@+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/DataConstructors.hs view
@@ -0,0 +1,862 @@+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 Support.MapBinaryInstance+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 0 (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 [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 0 (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) = putMap dt+    get = fmap DataTable getMap++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 = v } | v <- [ 2,4 ..]]+        vars =  [ tvr { tvrType = EVar t, tvrIdent = 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 = 0 } | 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 0 eStar) (EPi (tVr 0 eStar) eStar),+            conOrigSlots = [SlotNormal eStar,SlotNormal eStar],+            conExpr = ELam (tVr 2 eStar) (ELam (tVr 4 eStar) (EPi (tVr 0 (EVar $ tVr 2 eStar)) (EVar $ tVr 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 2 rt) (ELit (litCons { litName = dc, litArgs = [EVar (tVr 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 => DataTable -> E -> E -> m ()+typesCompatable dataTable a b = f (-2 :: Id) 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 = 0, tvrType =  a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) | 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 = 0, tvrType =  a}) b)  | 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 = do+            f c (tvrType va) (tvrType vb)+            f (c - 2) (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 = 2,  tvrType = typ }+        v2 = tvr { tvrIdent = 4,  tvrType = typ }+        i1 = tvr { tvrIdent = 6,  tvrType = it }+        i2 = tvr { tvrIdent = 8,  tvrType = it }+        b3 = tvr { tvrIdent = 10, tvrType = tBoolzh }+        val1 = tvr { tvrIdent = 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 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 12 rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr 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 = -1 } 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 [2,4..] ()) vs+            tipe' ty+        subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = 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 [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 = 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 [ (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 (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 [ (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 [ (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 = 0, tvrType = t1 }) t2) = 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_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 view
@@ -0,0 +1,13 @@+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 => DataTable -> E -> E -> m ()+updateLit :: DataTable -> Lit e t -> Lit e t+slotTypes :: DataTable -> Name -> E -> [E]+mktBox :: E -> E
+ src/DerivingDrift/DataP.hs view
@@ -0,0 +1,34 @@+-- 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 view
@@ -0,0 +1,81 @@+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 view
@@ -0,0 +1,110 @@+-- 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 view
@@ -0,0 +1,224 @@+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 view
@@ -0,0 +1,41 @@+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 view
@@ -0,0 +1,71 @@+-- | 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 view
@@ -0,0 +1,184 @@+{-# 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 ds = enclose l r (hcat $ punctuate s ds)+    enclose l r x   = l <> x <> r+    list            = encloseSep lbracket rbracket comma+    tupled          = encloseSep lparen   rparen  comma+    semiBraces      = encloseSep lbrace   rbrace  semi+++------------------------+-- Basic building blocks+------------------------++tshow :: (Show a,DocLike b) => a -> b+tshow x = text (show x)++++lparen,rparen,langle,rangle,+    lbrace,rbrace,lbracket,rbracket,squote,+    dquote,semi,colon,comma,space,dot,backslash,equals+    :: TextLike a => a+lparen          = char '('+rparen          = char ')'+langle          = char '<'+rangle          = char '>'+lbrace          = char '{'+rbrace          = char '}'+lbracket        = char '['+rbracket        = char ']'++squote          = char '\''+dquote          = char '"'+semi            = char ';'+colon           = char ':'+comma           = char ','+space           = char ' '+dot             = char '.'+backslash       = char '\\'+equals          = char '='+++squotes x = enclose squote squote x+dquotes x = enclose dquote dquote x+parens x = enclose lparen rparen x+braces x = enclose lbrace rbrace x+brackets x = enclose lbracket rbracket x+angles x = enclose langle rangle x++-----------------------------------------------------------+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]+-----------------------------------------------------------+punctuate _ []      = []+punctuate _ [d]     = [d]+punctuate p (d:ds)  = (d <> p) : punctuate p ds++------------------+-- String instance+------------------+instance TextLike String where+    empty = ""+    text x = x++instance TextLike Char where+    empty = error "TextLike: empty char"+    char x = x+    text [ch] = ch+    text _ = error "TextLike: string to char"++instance DocLike String where+    a <> b = a ++ b+    a <+> b = a ++ " " ++ b+++instance TextLike ShowS where+    empty = id+    text x = (x ++)+    char c = (c:)++instance DocLike ShowS where+    a <> b = a . b++instance (TextLike a, Monad m) => TextLike (m a) where+    empty = return empty+    char x = return (char x)+    text x = return (text x)+++instance (DocLike a, Monad m,TextLike (m a)) => DocLike (m a) where+    a <$> b = do+        a <- a+        b <- b+        return (a <$> b)+    a <> b = do+        a <- a+        b <- b+        return (a <> b)+    a <+> b = do+        a <- a+        b <- b+        return (a <+> b)+    vcat xs = sequence xs >>= return . vcat+    hsep xs = sequence xs >>= return . hsep++---------------------+-- HughesPJ instances+---------------------++instance TextLike P.Doc where+    empty = P.empty+    text = P.text+    char = P.char++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 view
@@ -0,0 +1,66 @@++-- | 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 view
@@ -0,0 +1,82 @@+{-# 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 IO      (Handle,hPutStr,hPutChar,stdout)+import Doc.DocLike hiding(empty)+import qualified Doc.DocLike as DocLike+import Data.Monoid++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 view
@@ -0,0 +1,170 @@+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 Info.Types+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 TVars 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 | n == 0  = 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 =  0, 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 = 0, tvrType =  t}) = do+        t' <- f t+        nfo <- lift $ idann 0 (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 view
@@ -0,0 +1,158 @@+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 view
@@ -0,0 +1,275 @@+module E.Binary() where++import StringTable.Atom+import Data.Binary+import E.Type+import Monad+import Name.Binary()+import {-# SOURCE #-} Info.Binary(putInfo,getInfo)+++-- Binary instance+data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Word32++instance Binary TVr where+    put (TVr { tvrIdent = 0, tvrType =  e, tvrInfo = nf} ) = do+        put (TvrBinaryNone)+        put e+        putInfo nf+    put (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) | Just x <- intToAtom i = do+        put (TvrBinaryAtom x)+        put e+        putInfo nf+    put (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) = do+        put (TvrBinaryInt $ fromIntegral i)+        put e+        putInfo nf+    get  = do+        (x ) <- get+        e <- get+        nf <- getInfo+        case x of+            TvrBinaryNone -> return $ TVr 0 e nf+            TvrBinaryAtom a -> return $ TVr (fromAtom a) e nf+            TvrBinaryInt i -> return $ TVr (fromIntegral 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 view
@@ -0,0 +1,139 @@+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 view
@@ -0,0 +1,429 @@+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++isEmptyId 0 = True+isEmptyId _ = False++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 :: Monad m => IM a -> DataTable ->  m a+runIM (IM im) dt = return $ runReader im (mempty,dt)++-- returns the demand type and whether it was found in the local environment or guessed+determineDemandType :: TVr -> Demand -> IM (Either DemandType E)+determineDemandType tvr demand = do+    let g (DemandSignature n dt@(DemandEnv phi _ :=> _)) = f n demand where+            f 0 (S _) = dt+            f n (S (Product [s])) = f (n - 1) s+            f _ _ = lazify (DemandEnv phi Absent) :=> []+    env <- getEnv+    case mlookup (tvrIdent tvr) env of+        Just (Left ds) -> return (Left $ g ds)+        Just (Right e) -> return (Right e)+        Nothing -> case Info.lookup (tvrInfo tvr) of+            Nothing -> return (Left absType)+            Just ds -> return (Left $ g ds)++extendSig (DemandSignature n1 t1) (DemandSignature n2 t2)  = DemandSignature (max n1 n2) (glb t1 t2)++splitSigma [] = (lazy,[])+splitSigma (x:xs) = (x,xs)++analyze :: E -> Demand -> IM (E,DemandType)+analyze e Absent = return (e,absType)+analyze (EVar v) s = do+    ddt <- determineDemandType v s+    (phi :=> sigma) <- case ddt of+        Left dt -> return dt+        Right e -> liftM snd $ analyze e s+    return (EVar v,(phi `glb` (demandEnvSingleton v s)) :=> sigma)+analyze (EAp e1 e2) s = do+    (e1',phi1 :=> sigma1') <- analyze e1 (sp [s])+    let (sa,sigma1) = splitSigma sigma1'+    (e2',phi2 :=> sigma2) <- analyze e2 sa+    return $ (EAp e1' e2',(phi1 `glb` phi2) :=> sigma1)+analyze el@(ELit lc@LitCons { litName = h, litArgs = ts@(_:_) }) (S (Product ss)) | length ss == length ts = do+    dataTable <- getDataTable+    case onlyChild dataTable h of+        True -> do  -- product type+            envs <- flip mapM (zip ts ss) $ \(a,s) -> do+                (_,env :=> _) <- analyze a s+                return env+            return (el,foldr1 glb envs :=> [])+        _ -> do+            rts <- mapM (\e -> analyze e lazy) ts+            return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts))+++analyze (ELit lc@LitCons { litArgs = ts }) _s = do+    rts <- mapM (\e -> analyze e lazy) ts+    return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts))+analyze e s | Just (t1,t2,pt) <- from_dependingOn e = do+    (t1',dt1) <- analyze t1 s+    (t2',dt2) <- analyze t2 lazy+    return (EPrim p_dependingOn [t1',t2'] pt,dt1 `glb` dt2)+analyze (EPrim ap ts pt) _s = do+    rts <- mapM (\e -> analyze e lazy) ts+    return (EPrim ap (fsts rts) pt, foldr glb absType (snds rts))+analyze (EPi tvr@TVr { tvrType = t1 } t2)  _s = do+    (t1',dt1) <- analyze t1 lazy+    (t2',dt2) <- analyze t2 lazy+    return (EPi tvr { tvrType = t1' } t2',dt1 `glb` dt2)++analyze (ELam x@TVr { tvrIdent = 0 } e) (S (Product [s])) = 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 = do+    nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) dataTable+    --flip mapM_ nds $ \ (t,_) ->+    --    putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t))+    return nds+++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 = do+    dsOut <- solveDs (progDataTable prog) (programDs prog)+    return $ programSetDs' dsOut prog++$(derive makeBinary ''Demand)+$(derive makeBinary ''SubDemand)+$(derive makeBinary ''DemandSignature)+$(derive makeBinary ''DemandType)
+ src/E/Diff.hs view
@@ -0,0 +1,48 @@++-- | 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 view
@@ -0,0 +1,167 @@+{-# 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 0 a) b++-- values++++tvrSilly = tVr ((-1)) 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 view
@@ -0,0 +1,226 @@+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 tvrIdent t == 0+         then Stats.mtick ("EtaExpand." ++ zeroName)+          else Stats.mtick ("EtaExpand.def.{" ++ tvrShowName t)+        n <- newName+        let nv = tt { tvrIdent = n }+            eb = EAp e (EVar nv)+        (ne,_) <- f (min - 1) a eb (subst tt (EVar nv) rt) _nns+        return (ELam nv ne,True)+    f min a e (EPi tt rt) _nns | min > 0 = do+        if tvrIdent t == 0+         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 = 0} (foldl EAp (EVar tvr) xs)+    return (fmap snd r)++{-+etaExpandAp _ _ [] = return Nothing  -- so simple renames don't get eta-expanded+etaExpandAp dataTable t as | Just (Arity n err) <- Info.lookup (tvrInfo t) = case () of+    () | n > length as -> do+            let e = foldl EAp (EVar t) as+            let (_,ts) = fromPi' dataTable (infertype dataTable e)+                ets = (take (n - length as) ts)+            mticks (length ets) ("EtaExpand.use.{" ++ tvrShowName t)+            let tvrs = f mempty [ (tvrIdent t,t { tvrIdent = n }) |  n <- [2,4 :: Int ..], not $ n `Set.member` freeVars (e,ets) | t <- ets ]+                f map ((n,t):rs) = t { tvrType = substMap map (tvrType t)} : f (Map.insert n (EVar t) map) rs+                f _ [] = []+            return (Just $ foldr ELam (foldl EAp e (map EVar tvrs)) tvrs)+       | err && length as > n -> do+            let ot = infertype dataTable (foldl EAp (EVar t) as)+            mticks (length as - n) ("EtaExpand.bottoming.{" ++ tvrShowName t)+            return $ Just (prim_unsafeCoerce ot (foldl EAp (EVar t) (take n as)))  -- we can drop any extra arguments applied to something that bottoms out.+       | otherwise -> return Nothing++etaExpandAp _ t as = return Nothing+-}++
+ src/E/Eval.hs view
@@ -0,0 +1,111 @@+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.PPrint+import E.E+import E.FreeVars+import {-# SOURCE #-} E.Show+import E.Subst++++eval :: E -> E+eval term = eval' term []  where+    -- final terms+    eval' t@EVar {} [] = t+    eval' (ELam v body) [] = check_eta $ ELam v (eval body)+    eval' (EPi v body) [] = check_eta $ EPi v (eval body)+    eval' e@Unknown [] = e+    eval' e@ESort {} [] = e+    eval' (ELit lc@LitCons { litArgs = es }) [] = ELit lc { litArgs = map eval es }+    eval' e@ELit {} [] = e++    -- argument applications+    eval' (ELit lc@LitCons { litArgs = es, litType = EPi tb tt }) (t:rest) = eval' (ELit lc { litArgs = es ++ [t], litType = subst tb t tt }) rest+    eval' (ELit LitCons { litArgs = es, litAliasFor = Just af }) (t:rest) = eval' af (es ++ t:rest)++    eval' (ELam v body) (t:rest) = eval' (subst v t body) rest+    eval' (EPi v body) (t:rest) = eval' (subst v t body) rest   -- fudge+    eval' (EAp t1 t2) stack = eval' t1 (t2:stack)+    eval' t@EVar {} stack = unwind t stack+    eval' ELetRec { eDefs = ds, eBody = e } stack = eval' (f (decomposeDs ds) e) stack where+        f [] e = e+        f (Left (x,y):ds) e =  subst x y (f ds e)+        f (Right _:_) _ = error $ "cannot eval recursive let"+    eval' e@(ELit LitCons {}) stack = unwind e stack+    eval' e _ = error $ "Cannot eval: " ++ show e++    unwind t [] = t+    unwind t (t1:rest) = unwind (EAp t $ eval t1) rest++    -- currently we do not do eta check. etas should only appear for good reason.+    check_eta x = x++++{- 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 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 = 0 }) _stack = 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 $ "Cannot strong: \n" ++ render (pprint (e,stack))++    unwind ds t [] = return t+    unwind ds t (t1:rest) = do+        e <-  eval' ds t1 []+        unwind ds (EAp t $ e) rest++    -- currently we do not do eta check. etas should only appear for good reason.+    check_eta x = return x+
+ src/E/FreeVars.hs view
@@ -0,0 +1,141 @@+{-# 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 [Int] 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 view
@@ -0,0 +1,1001 @@+module E.FromHs(+    convertDecls,+    convertRules,+    createInstanceRules,+    procAllSpecs,+    getMainFunction+    ) where++import Char+import Control.Monad.Trans+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.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 :: UniqueProducer m => [E] -> m [TVr]+newVars xs = f xs [] where+    f [] xs = return $ reverse xs+    f (x:xs) ys = do+        s <- newUniq+        f xs (tVr (2*s) x:ys)+++tipe t = f t where+    f (TAp t1 t2) = eAp (f t1) (f t2)+    f (TArrow t1 t2) =  EPi (tVr 0 (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 0 (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 = 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 j (getType z)) | z <- ts | j <- [2,4 ..], 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:_) = [ j |  j <- [2,4 ..], 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 -> Int -> (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 :: UniqueProducer m => DataTable -> [E] -> ([(TVr,String)] -> (E -> E,E)) -> 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) (if catalyst then RuleCatalyst else RuleUser) vs head args e2 | (catalyst,n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 | i <- [1..] ]+    g (HsPragmaRules rs) = mapM f rs+    g _ = return []+    f pr = do+        let ce = convertE tiData classHierarchy assumps dataTable (hsRuleSrcLoc pr)+        e1 <- ce (hsRuleLeftExpr pr)+        e2 <- ce (hsRuleRightExpr pr)+        (ts,cs) <- runNameMT $ do+            ts <- flip mapM (filter (sortKindLike . getType) $ freeVars e1) $ \tvr -> do+                --return (tvrIdent tvr,tvr)+                nn <- newNameFrom (map (:'\'':[]) ['a' ..])+                return (tvrIdent tvr,tvr { tvrIdent = toId (toName TypeVal nn) })+            cs <- flip mapM [toTVr assumps dataTable (toName Val v) | (v,_) <- hsRuleFreeVars pr ] $ \tvr -> do+                let ur = show $ unRename $ 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,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 :: UniqueProducer m => DataTable -> E -> E -> 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 :: UniqueProducer m => DataTable -> E -> E -> 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 view
@@ -0,0 +1,163 @@+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 }++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) }++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 view
@@ -0,0 +1,345 @@+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++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 = 0 } | t <- droppedAs ]+        tvr' = tvr { tvrIdent = nname, tvrType = getType rbody }+        ne' = foldr ELam (ELetRec [(tvr',rbody)]  (foldl EAp (EVar tvr') (map EVar keptAs))) args+        ans = do+            mtick $ "SimpleRecursive.{" ++ pprint t+            ne' <- g ne'+            return [(t,ne')]+    f _ (Right ts) =  gds ts+    gds ts = mapM g' ts >>= return where+        g' (t,e) = g e >>= return . (,) t+    g elet@ELetRec { eDefs = ds } =  do+        ds'' <- mapM (f False) (decomposeDs ds)+        e' <- g $ eBody elet+        return elet { eDefs = concat ds'', eBody = e' }+    g e = emapE g e+++data S = S {+    funcName :: Name,+    topVars :: IdSet,+    isStrict :: Bool,+    declEnv :: [(TVr,E)]+    }+$(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]++    calcFixpoint "Liftees" fixer+    vs <- supplyReadValues sup+    let nlset =  (fromList [ x | (x,False) <- vs])+    printf "%d lambdas not lifted\n" (size nlset)+    return nlset++implies :: Value Bool -> Value Bool -> IO ()+implies x y = addRule $ y `isSuperSetOf` x++assert x = value True `implies` x+++lambdaLift ::  Program -> IO Program+lambdaLift prog@Program { progDataTable = dataTable, progCombinators = cs } = do+    noLift <- calculateLiftees prog+    let wp =  fromList [ combIdent x | x <- cs ] :: IdSet+    fc <- newIORef []+    fm <- newIORef mempty+    statRef <- newIORef mempty+    let z comb  = do      +            (n,as,v) <- return $ combTriple comb+            let ((v',(cs',rm)),stat) = runReader (runStatT $ execUniqT 1 $ runWriterT (f v)) S { funcName = mkFuncName (tvrIdent n), topVars = wp,isStrict = True, declEnv = [] }+            modifyIORef statRef (mappend stat)+            modifyIORef fc (\xs -> combTriple_s (n,as,v') comb:cs' ++ xs)+            modifyIORef fm (rm `mappend`)+        shouldLift t _ | tvrIdent t `member` noLift = False+        shouldLift _ ECase {} = True+        shouldLift _ ELam {} = True+        shouldLift _ _ = False+        f e@(ELetRec ds _)  = do+            let (ds',e') = decomposeLet e+            h ds' e' []+        f e = do+            st <- asks isStrict+            if ((tvrIdent tvr `notMember` noLift && isELam e) || (shouldLift tvr e && not st)) then do+                (e,fvs'') <- pLift e+                doBigLift e fvs'' return+             else g e+        -- This ensures there are no 'orphaned type terms' when something is+        -- lifted out.  The problem occurs when a type is subsituted in some+        -- places and not others, the type as free variable will not be the+        -- same as its substituted instances if the variable is bound by a+        -- lambda, Although the program is still typesafe, it is no longer+        -- easily proven so, so we avoid the whole mess by subtituting known+        -- type variables within lifted expressions. This can not duplicate work+        -- since types are unpointed, but might change space usage slightly.+--        g ec@ECase { eCaseScrutinee = (EVar v), eCaseAlts = as, eCaseDefault = d} | sortKindLike (tvrType v) = do+--            True <- asks isStrict+--            d' <- fmapM f d+--            let z (Alt l e) = do+--                    e' <- local (declEnv_u ((v,followAliases dataTable $ patToLitEE l):)) $ f e+--                    return $ Alt l e'+--            as' <- mapM z as+--            return $ caseUpdate ec { eCaseAlts = as', eCaseDefault = d'}+        g (ELam t e) = do+            e' <- local (isStrict_s True) (g e)+            return (ELam t e')+        g e = emapE' f e+        pLift e = do+            gs <- asks topVars+            ds <- asks declEnv+            let fvs = freeVars e+                fvs' = filter (not . (`member` gs) . tvrIdent) fvs+                --ss = filter (sortKindLike . tvrType) fvs'+                ss = []+                f [] e False = return (e,fvs'')+                f [] e True = pLift e+                f (s:ss) e x+                    | Just v <- lookup s ds = f ss (removeType s v e) True   -- TODO subst+                    | otherwise = f ss e x+                fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars+            f ss e False+        h (Left (t,e):ds) rest ds' | shouldLift t e = do+            (e,fvs'') <- pLift e+            case fvs'' of+                [] -> doLift t e (h ds rest ds')+                fs -> doBigLift e fs (\e'' -> h ds rest ((t,e''):ds'))+        h (Left (t,e@ELam {}):ds) rest ds' = do+            let (a,as) = fromLam e+            a' <- local (isStrict_s True) (f a)+            h ds rest ((t,foldr ELam a' as):ds')++        h (Left (t,e):ds) rest ds'  = do+            let fvs =  freeVars e :: [Id]+            gs <- asks topVars+            let fvs' = filter (not . (`member` gs) ) fvs+            case fvs' of+                [] -> doLift t e (h ds rest ds')  -- We always lift CAFS to the top level for now. (GC?)+                _ ->  local (isStrict_s False) (f e) >>= \e'' -> h ds rest ((t,e''):ds')+        --h (Left (t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds')+        h (Right rs:ds) rest ds' | any (uncurry shouldLift) rs  = do+            gs <- asks topVars+            let fvs =  freeVars (snds rs)--   (Set.fromList (map tvrIdent $ fsts rs) `Set.union` gs)+            let fvs' = filter (not . (`member` (fromList (map tvrIdent $ fsts rs) `mappend` gs) ) . tvrIdent) fvs+                fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars+            case fvs'' of+                [] -> doLiftR rs (h ds rest ds')  -- We always lift CAFS to the top level for now. (GC?)+                fs -> doBigLiftR rs fs (\rs' -> h ds rest (rs' ++ ds'))+        h (Right rs:ds) e' ds'   = do+            rs' <- local (isStrict_s False) $ do+                flip mapM rs $ \te -> case te of+                    (t,e@ELam {}) -> do+                        let (a,as) = fromLam e+                        a' <- local (isStrict_s True) (f a)+                        return (t,foldr ELam a' as)+                    (t,e) -> do+                        e'' <- f e+                        return (t,e'')+            h ds e' (rs' ++ ds')+        h [] e ds = f e >>= return . eLetRec ds+        tellCombinator c = tell ([combTriple_s c emptyComb],mempty)+        tellCombinators c = tell (map (`combTriple_s` emptyComb) c,mempty)+        doLift t e r = local (topVars_u (insert (tvrIdent t)) ) $ do+            --(e,tn) <- return $ etaReduce e+            let (e',ls) = fromLam e+            mtick (toAtom $ "E.LambdaLift.doLift." ++ typeLift e ++ "." ++ show (length ls))+            --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")+            e'' <- local (isStrict_s True) $ f e'+            t <- globalName t+            tellCombinator (t,ls,e'')+            r+        doLiftR rs r = local (topVars_u (mappend (fromList (map (tvrIdent . fst) rs)) )) $ do+            flip mapM_ rs $ \ (t,e) -> do+                --(e,tn) <- return $ etaReduce e+                let (e',ls) = fromLam e+                mtick (toAtom $ "E.LambdaLift.doLiftR." ++ typeLift e ++ "." ++ show (length ls))+                --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")+                e'' <- local (isStrict_s True) $ f e'+                t <- globalName t+                tellCombinator (t,ls,e'')+            r+        globalName tvr | not $ isValidAtom (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 view
@@ -0,0 +1,348 @@+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) | i == 0 || i `notMember` freeIds b  = do+        t <- f t+        b <- f b+        dl (\ [t,b] -> EPi tvr { tvrIdent = 0, 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 -> IO Program+programFloatInward prog = do+    let binds = G.scc $  G.newGraph [ (c ,freeVars c) | c <- progCombinators prog, combIdent c  `notElem` map combIdent epoints ] (combIdent . fst) (idSetToList . snd)+        epoints = [ c | c@Comb { combHead = x } <- progCombinators prog, (tvrIdent x `member` progEntry prog) || forceNoinline x || getProperty prop_INSTANCE x || getProperty prop_SPECIALIZATION x ]+        (oall,pints) = sepByDropPoint dpoints  (reverse binds)+        dpoints = map freeVars epoints+        nprog = progCombinators_s ([ combBody_u (\v -> fi c v y) c | (c,y) <- zip epoints pints] ++ [ combBody_u (\y -> floatInwardE y []) c | c <- dsBinds oall]) prog+        fi k = if getProperty prop_ONESHOT k then floatInwardE' else floatInwardE+    --mapM_ (putStrLn . pprint) (map fst $ dsBinds (concat pints))+    --Prelude.print (cupbinds binds)+    --Prelude.print dpoints+    --Prelude.putStrLn (pprint $ map fst (dsBinds binds))+    --Prelude.putStrLn (pprint $ (map fst $ dsBinds oall,map (\binds -> map fst $ dsBinds binds) pints))+    let mstats = mconcat [ Stats.singleton $ "FloatInward.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds (concat pints)]+        mstats' = mconcat [ Stats.singleton $ "FloatInward.all.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds oall]+        nstats = progStats prog `mappend` mstats `mappend` mstats'+    --nprog <- programMapBodies (return . floatInward) nprog+    return nprog { progStats = nstats }+++--cupbinds bs = f bs where+--    f (Left ((t,_),fv):rs) = (tvrShowName t,fv):f rs+--    f (Right ds:rs) = f $ map Left ds ++ rs+--    f [] = []++floatInward ::+    E  -- ^ input term+    -> E  -- ^ output term+floatInward e = floatInwardE e [] 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++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]+++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 view
@@ -0,0 +1,208 @@+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 -> Int -> (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 view
@@ -0,0 +1,145 @@+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.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 . isValidAtom) (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 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_ f prog = mapM_ f (programDs prog)++hPrintProgram fh prog@Program {progCombinators = cs, progDataTable = dataTable } = do+    sequence_ $ intersperse (hPutStrLn fh "") [ hPrintCheckName fh dataTable v e | Comb { combHead = v, combBody = e } <- cs]+    when (progMain prog /= emptyId) $+        hPutStrLn fh $ "MainEntry: " ++ pprint (progMainEntry prog)+    when (progEntry prog /= singleton (progMain prog)) $+        hPutStrLn fh $ "EntryPoints: " ++ hsep (map pprint (progEntryPoints prog))++printProgram prog = hPrintProgram IO.stderr prog++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 view
@@ -0,0 +1,278 @@+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()+import E.Subst+import E.Values+import GenUtil+import Info.Types+import Support.MapBinaryInstance()+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 (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 = rule where+    rule = emptyRule {+        ruleHead = head,+        ruleBinds = fvs,+        ruleArgs = args,+        ruleType = ruleType,+        ruleNArgs = length args,+        ruleBody = body,+        ruleUniq = uniq,+        ruleName = toAtom $ "Rule.User." ++ name+        }+++-- | find substitution that will transform the left term into the right one,+-- only substituting for the vars in the list++match :: Monad m =>+    (Id -> Maybe E)      -- ^ function to look up values in the environment+    -> [TVr]              -- ^ vars which may be substituted+    -> E                  -- ^ pattern to match+    -> E                  -- ^ input expression+    -> m [(TVr,E)]+match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () (-2::Int)) 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 | i < 0 || j < 0  = 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 = do+        un (tvrType va) (tvrType vb) mm c+        un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm (c - 2)+
+ src/E/SSimplify.hs view
@@ -0,0 +1,1096 @@+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 = 0, tvrType =  a} b) = 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 =  0, 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 = 0 }+    _ -> annb' tvr++-- add ocucrance info+annbind idm tvr = case mlookup (tvrIdent tvr) idm of+    Nothing -> annb notUsedInfo tvr { tvrIdent = 0 }+    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' 0 _e env = env+insertSuspSubst' t e env = cacheSubst env { envSubst = minsert t (susp e (envSubst env)) (envSubst env) }++insertRange :: Id -> Range -> Env -> Env+insertRange 0 e env = 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' 0 _e env = env+insertDoneSubst' t e env = insertRange t (Done e) env+++insertInScope :: Id -> Binding -> Env -> Env+insertInScope 0 _b env = 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 | isValidAtom 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 n == 0 then return 0 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 = 0 } [] (Just d) | 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,0) -> 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 | 0 `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, n /= 0]+                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+    didInline z zs = return (foldl EAp z zs)+    didInline z zs = do+        used <- smUsedNames+        let (ne,nn) = runRename used (foldl EAp z zs)+        smAddNamesIdSet nn+        return ne+    appVar v xs = 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')+++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 ()++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 (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 view
@@ -0,0 +1,291 @@+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 view
@@ -0,0 +1,272 @@+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 0 = (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'+        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 | tvrIdent tvr == 0 = 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 $ isValidAtom (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 | tvrIdent tvr == 0                = 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 = 0, tvrType =  e1}) e2) = 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 = 0 })+            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 view
@@ -0,0 +1,18 @@+-- -*- 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 view
@@ -0,0 +1,296 @@+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 Data.Monoid+import qualified Data.Traversable as T+import List hiding(union,insert,delete)++import E.E+import E.FreeVars()+import Name.Id+import Name.Names (tc_Arrow)+import {-# SOURCE #-} E.Show+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 ((/= 0) . 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 = 0 }) _ e = 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 = 0 }) _ e = 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 | n == 0 || (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 =  0, 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 = 0, tvrType =  t}) = 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 tvrIdent t == 0 then b else subst t e b+eAp (ELam t b) e = if tvrIdent t == 0 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 = 0, tvrType = t}) e  = do+        t' <- inType (f t)+        e' <- f e+        return $ lam (tvr { tvrIdent =  0, 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 = 0, tvrType =  t}) = 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 view
@@ -0,0 +1,498 @@+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 RawFiles(viaghc_hs)+import Support.CanType+import Support.FreeVars+import Util.Gen+import Util.SetLike+import qualified FlagDump as FD++progress str = wdump FD.Progress $  (putErrLn str) >> hFlush stderr+++{-# NOINLINE compileToHs #-}+compileToHs :: Program -> IO ()+compileToHs prog = do+    (v,_,Coll { collNames = ns, collPrims = prims }) <- runRWST (fromTM $ transE (programE prog)) emptyEnvironment 1+++    let rv = render (text "theRealMain = " <> v)+    let data_decls = render (transDataTable (progDataTable prog) ns) ++ "\n"+    let foreign_decls = render (transForeign $ Set.toList prims) ++ "\n"+    let fn = optOutName options+    let cf = (fn ++ "_code.hs")+    progress ("Writing " ++ show cf)+    name <- System.getProgName+    args <- getArguments+    let argstring = simpleQuote (name:args)+        comm = shellQuote $ ["ghc", "-O", cf, "-o", fn ]+    writeFile cf $ unlines ["-- " ++ argstring,"-- " ++ comm,"",viaghc_hs,render restate,data_decls,rv,"",foreign_decls]+    progress ("Running: " ++ comm)+    r <- System.system comm+    when (r /= System.ExitSuccess) $ fail "Hs code did not compile."+    return ()++cTypeInfoT (ELit LitCons { litAliasFor = Just af }) = cTypeInfoT af+cTypeInfoT (ELit LitCons { litName = n }) | (RawType,t) <- fromName n = cTypeInfo t++cTypeInfo "wchar_t" = ("Char#","C#","Char")+cTypeInfo "HsChar" = ("Char#","C#","Char")+cTypeInfo "HsPtr" =  ("Addr#","Ptr","(Ptr ())")+cTypeInfo "HsFunPtr" =  ("Addr#","Ptr","(Ptr ())")+cTypeInfo n = (if primTypeIsSigned pi then "Int#" else "Word#",v,i) where+        (v,i) = if primTypeIsSigned pi then ('I':nn ++ "#","Int" ++ nn) else ('W':nn ++ "#","Word" ++ nn)+        nn = show $ primTypeSizeOf pi * 8+        Just pi = primitiveInfo n++showCType n = fst3 $ cTypeInfo n++restate = vcat $ map f restated where+    f (n,nn,v) = g (nameType n) <> text v <+> text "=" <+> showTCName nn n+    g DataConstructor = empty+    g TypeConstructor = text "type "+    restated = [+        (dc_Cons,0,"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 view
@@ -0,0 +1,192 @@++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 (\x -> do x <- (do (aa,ab) <- return x; aa <- mapmTvr g aa;ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab+    z ec@ECase {} = do+        e' <- f $ eCaseScrutinee ec+        b' <- T.mapM g (eCaseBind ec)+        as' <- mapM mapmAlt (eCaseAlts ec)+        d' <- T.mapM f (eCaseDefault ec)+        t' <- g (eCaseType ec)+        return $ caseUpdate ec { eCaseScrutinee =e', eCaseBind = b', eCaseAlts = as', eCaseDefault = d', eCaseType = t'}+    --    aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- T.mapM f x; y <- f y; return (x,y)) ab; return $ ECase aa ab+    z (EPrim aa ab ac) = do ab <- mapM f ab;ac <- g ac; return $ EPrim aa ab ac+    z (EError aa ab) = do ab <- g ab; return $ EError aa ab+    mapmTvr = T.mapM+    mapmAlt (Alt lc@LitCons {  litArgs = xs, litType = t } e) = do+        e' <- f e+        xs' <- mapM (T.mapM g) xs+        t' <- g t+        return $ Alt lc { litArgs = xs', litType = t' } e'+    mapmAlt (Alt l e) = do+        e' <- f e+        l' <- T.mapM g l+        return (Alt l' e')++++instance HasSize E where+    size = eSize++eSize :: E -> Int+eSize e = n where+    (_, MInt n) = runWriter (f e)+    f e@ELit {} = tell (MInt 1) >> return e+    f e@EPrim {} = tell (MInt 1) >> return e+    f e@EError {} = tell (MInt 1) >> return e+    f e = tell (MInt 1) >> emapE' f e+++renameE :: IdSet -> IdMap E -> E -> (E,IdSet)+renameE initSet initMap e = runReader (runIdNameT' $ addBoundNamesIdMap initMap >> addBoundNamesIdSet initSet >> f e) initMap  where+    f,f' :: E -> IdNameT (Reader (IdMap E)) E+    f' e = f e+    f  (EAp a b) = return EAp `ap` f a `ap` f b+    f  (ELit lc@LitCons { litArgs = xs, litType = t }) = do+        xs' <- mapM f xs+        t' <- f' t+        return $ ELit lc { litArgs = xs', litType = t' }+    f (ELit (LitInt n t)) = do+        t' <- f' t+        return (ELit (LitInt n t'))+    f (EError x t) = return (EError x) `ap` f' t+    f (EPrim n es t) = do+        es' <- mapM f es+        t' <- f' t+        return $ EPrim n es' t'+    f (ELam tvr e) = lp f' ELam tvr e+    f (EPi tvr e) = lp f EPi tvr e+    f  e@(EVar TVr { tvrIdent = n }) = do+        im <- lift ask+        case mlookup n im of+            Just n' -> do return n'+            Nothing -> return e+    f x@(ESort {}) = return x+    f Unknown = return Unknown+    f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } = do+        e' <- f e+        t' <- f' (eCaseType ec)+        addNames $ map tvrIdent (caseBinds ec)+        (ob,b') <- ntvr False f' b+        localSubst ob $ do+            as' <- mapM da as+            d' <- T.mapM f d+            return $ caseUpdate ec { eCaseScrutinee = e', eCaseType = t', eCaseBind = b', eCaseAlts = as', eCaseDefault = d' }+    f ELetRec { eDefs = ds, eBody = e } = do+        addNames (map (tvrIdent . fst) ds)+        ds' <- mapM ( ntvr False f' . fst) ds+        localSubst (mconcat $ fsts ds') $ do+            es <- mapM f (snds ds)+            e' <- f e+            return (ELetRec (zip (snds ds') es) e')+    --f e = error $ "renameE.f: " ++ show e+    da :: Alt E -> IdNameT (Reader (IdMap E)) (Alt E)+    da (Alt lc@LitCons { litName = n, litArgs = xs, litType = t } l) = do+        t' <- f' t+        xs' <-  mapM (ntvr False f') xs+        localSubst (mconcat [ x | (x,_) <- xs']) $ do+            l' <- f l+            return (Alt lc { litArgs = snds xs', litType = t' } l')+    da (Alt (LitInt n t) l) = do+        t' <- f' t+        l' <- f l+        return (Alt (LitInt n t') l')+    localSubst :: (IdMap E) -> IdNameT (Reader (IdMap E)) a  -> IdNameT (Reader (IdMap E)) a+    localSubst ex action = do local (ex `mappend`) action+    ntvr _ fg tv@TVr { tvrIdent = 0, tvrType = t} = 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 || isValidAtom 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 view
@@ -0,0 +1,283 @@+-- | 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 = 0, 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 0 (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 = 0, 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 view
@@ -0,0 +1,446 @@+-- | 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.Info(infoMapM,infoMap)+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)+        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+        lamdel _ nfo = return (Info.delete (undefined :: Value 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+    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+    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 = 0, 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 = 0 },+            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 view
@@ -0,0 +1,476 @@+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:" </> 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 = 0 })) = 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 = 0 },_) = 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 (/= 0) $ 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 dataTable e1 e2 of+            Right () -> return (e1)+            Left s -> failDoc $ hsep [text "eq:",text s, align $ vcat [ prettyE (e1),prettyE (e2) ]  ]+    fceq nds e1 t2 = do+        withContextDoc (hsep [text "fceq:", align $ vcat [parens $ prettyE e1,  parens $ prettyE t2]]) $ do+        t1 <- inferType' nds e1+        eq' nds t1 t2+    boxCompat (ELit (LitCons { litName = n }))  t | Just e <- fromConjured modBox n =  e == getType t+    boxCompat _ _ = False+++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':" </> 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 = 0 }) = 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 () (-2::Int)) 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 | i < 0 || j < 0  = 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 = do+        un (tvrType va) (tvrType vb) mm c+        un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm (c - 2)++$(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 = 0 }) = 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 view
@@ -0,0 +1,300 @@+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 0 (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 0 (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 0 (getType e)), eCaseType = getType alt,  eCaseAlts =  alts }+eCase e alts els = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr 0 (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 = 0 } _ e' = 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 ((/= 0) . 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 ((/= 0) . 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 0 (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 view
@@ -0,0 +1,164 @@+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 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 = 0 } _ = (Absent,t)+    g t (Demand.S subs)+       | Just con <- getProduct dataTable tt = (Cons con (as con),t)+         where+            as con = [ g TVr { tvrIdent = n, tvrType = st, tvrInfo = mempty } demand  | st <- slotTypes dataTable (conName con) tt | n <- tmpNames Val (tvrIdent t) | demand <- fsubs subs]+            tt = getType t+    g t Demand.Absent | isLifted (EVar t) = (Absent,t)+    g t _ = (Plain,t)+    f (ELam t e) (demand:ss) (Fun x) ts = f e ss x (g t demand:ts)+    f e _ (Tup n _) ts | isCPR n = return (Just n,e,reverse ts)+    f e _ (Tag [n]) ts | isCPR n = return (Just n,e,reverse ts)+    f e _ _ ts | any (not . isPlain . fst) ts = return (Nothing ,e,reverse ts)+    f _ _ _ _ = fail "not workwrapable"+    isCPR n | isBoxed n, onlyChild dataTable n = True+            | otherwise = False+    isBoxed n = isJust $ do+        Constructor { conInhabits = c } <- getConstructor n dataTable+        if c == s_Star then return () else do+        Constructor { conInhabits = c } <- getConstructor c dataTable+        if c == s_Star then return () else Nothing+wrappable _ _ _ = fail "Only lambdas are wrappable"++workerName x = case fromId x of+    Just y -> toId (toName Val ("W@",'f':show y))+    Nothing -> toId (toName Val ("W@",'f':show x))++tmpNames ns x = case fromId x of+    Just y  -> [toId (toName ns ("X@",'f':show y ++ "@" ++ show i)) | i <- [(1::Int)..] ]+    Nothing -> [toId (toName ns ("X@",'f':show x ++ "@" ++ show i)) | i <- [(1::Int)..] ]++workWrap' :: MonadStats m => DataTable -> TVr -> E -> m ((TVr,E),(TVr,E))+workWrap' _dataTable tvr _e+    | badProps `intersects` getProperties tvr = fail "Don't workwrap this"+    where badProps = fromList [prop_WRAPPER,prop_INLINE,prop_SUPERINLINE,prop_PLACEHOLDER,prop_NOINLINE]+workWrap' dataTable tvr e | isJust res = ans where+    res@(~(Just (cname,body,sargs))) = wrappable dataTable tvr e+    args = snds sargs+    args' = concatMap f sargs where+        f (Absent,_) = []+        f (Plain,t) = [t]+        f (Cons c ts,_) = concatMap f ts+    lets = concatMap f (zip sargs (map show naturals)) where+        f ((Absent,t),n) = [(t,EError ("WorkWrap.Absent." ++ tvrShowName tvr ++ "." ++ n) (getType t))]+        f ((Plain,_),_) = []+        f ((Cons c ts,t),n) = [(t,ELit (updateLit dataTable litCons { litName = conName c, litArgs = map EVar (snds ts), litType = getType t }))] ++ concatMap f (zip ts [ n ++ "." ++ show i | i <- naturals])+    cases e = f sargs where+        f [] = e+        f ((Absent,_):rs) = f rs+        f ((Plain,_):rs) = f rs+        f ((Cons c ts,t):rs) = eCase (EVar t) [Alt (updateLit dataTable litCons { litName = conName c, litArgs = snds ts, litType = getType t }) (f (ts ++ rs))] Unknown+    nprops = insert prop_WORKER $ getProperties tvr `intersection` fromList [prop_JOINPOINT, prop_ONESHOT]+    ans = doTicks >> return ((setProperty prop_WRAPPER tvr,wrapper),(tvr',worker))+    tvr' = putProperties nprops $ TVr { tvrIdent = workerName (tvrIdent tvr), tvrInfo = mempty, tvrType = wt }+    worker = foldr ELam body' (args' ++ navar) where+        body' = eLetRec lets $ case cname of+            Just cname -> eCase body [cb] Unknown where+                cb = Alt (updateLit dataTable litCons { litName = cname, litArgs = vars, litType = bodyTyp }) (if isSingleton then EVar sv else (ELit $ unboxedTuple (map EVar vars)))+            Nothing -> body+    wrapper = foldr ELam ne args where+        workerCall = (foldl EAp (EVar tvr') (map EVar args' ++ navalue))+        ne | Just cname <- cname, isSingleton = cases $ eStrictLet sv workerCall  (ELit $ updateLit dataTable litCons { litName = cname, litArgs = [EVar sv], litType = bodyTyp })+           | Just cname <- cname = let ca = Alt (unboxedTuple vars) (ELit $ updateLit dataTable litCons { litName = cname, litArgs = (map EVar vars), litType = bodyTyp }) in  cases $ eCase workerCall [ca] Unknown+           | otherwise = cases $ workerCall+    getName (Just x) = x+    getName Nothing  = error ("workWrap': cname = Nothing: tvr = "++show tvr)+    vars@(~[sv]) = [  tVr i t | t <- slotTypes dataTable (getName cname) bodyTyp | i <- newIds dontUseThese ]+    dontUseThese = freeIds (getType tvr) `mappend` freeIds bodyTyp --`mappend` freeIds (EAp (getType tvr) $ EAp (EVar tvr) e)+    isSingleton = case vars of+        [v] -> getType (getType v) == eHash+        _ -> False+    Just wt = typecheck dataTable  worker+    Just bodyTyp = typecheck dataTable body+    -- This is to add a dummy arg so workers arn't turned into updatable CAFs+    --needsArg =  all (isJust . fst) sargs && null (concat [ xs | (Just (_,xs),_) <- sargs])+    needsArg = null args'+    (navar,navalue) = if needsArg then ([tvr { tvrType = ltTuple' []}],[eTuple' []]) else ([],[])+    doTicks = do+        case cname of+            --Just n -> mtick ("E.Workwrap.CPR.{" ++ tvrShowName tvr ++ "." ++ show n ++ "}")+            Just n -> mtick ("E.Workwrap.CPR.{"  ++ show n ++ "}")+            _ -> return ()+        let argw cn (Absent,_) = mtick $ cn ++ ".absent"+            argw cn (Cons n ts,_) = mtick  nname >> mapM_ (argw nname) ts where+                nname = cn ++ ".{"  ++ show (conName n) ++ "}"+            argw _ _ = return ()+        mapM_ (argw "E.Workwrap.arg") sargs+workWrap' _dataTable tvr e = fail "not workWrapable"+++{-# NOINLINE workWrapProgram #-}+workWrapProgram :: Program -> Program+workWrapProgram prog = ans where+    (nds,stats) = performWorkWrap (progDataTable prog) (programDs prog)+    ans = programSetDs' nds prog { progStats = progStats prog `mappend` stats }++{-# NOINLINE performWorkWrap #-}+performWorkWrap :: DataTable -> [(TVr,E)] -> ([(TVr,E)],Stats.Stat)+performWorkWrap dataTable ds = runWriter (wwDs ds) where+    --wwDs :: [(TVr,E)] -> Stats.StatT Identity [(TVr,E)]+    wwDs ds = liftM concat $ mapM wwDef ds+    --wwDef :: (TVr,E) -> Stats.StatT Identity [(TVr,E)]+    wwDef (tvr,e) = case runStatT (workWrap' dataTable tvr e) of+        Just (((tx,x),(ty,y)),st) -> do+            --Stats.mtick a_workWrap+            tell st+            y' <- wwE y+            return ([ (tx,x), (ty,y') ] :: [(TVr,E)])+        Nothing -> do+            e' <- wwE e+            return ([(tvr,e')]:: [(TVr,E)])+    --wwE :: E -> Stats.StatT Identity E+    wwE ELetRec { eDefs = ds, eBody =  e } = do+        ds' <- wwDs ds+        e' <- wwE e+        return (ELetRec ds' e')+    wwE e = emapE' wwE e+
+ src/FindFixpoint.hs view
@@ -0,0 +1,82 @@+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 view
@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-- find fixpoint of constraint problem++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` (ConstValue v2) = Rule $ propagateValue v2 rv+(IV rv) `isSuperSetOf` v2 = Rule $ addAction v2 (\x -> propagateValue x rv)+(IOValue iov) `isSuperSetOf` v2 = Rule $ iov >>= unRule . (`isSuperSetOf` v2)+ConstValue v1 `isSuperSetOf` ConstValue v2 | v2 `lte` v1 =  Rule $ return ()+ConstValue {} `isSuperSetOf` _ = Rule $  fail "Fixer.isSuperSetOf: You cannot modify a constant value"+UnionValue {} `isSuperSetOf` _ = Rule $  fail "Fixer: You cannot modify a union value"++-- | the function must satisfy the rule that if a >= b then f(a) implies f(b)+conditionalRule :: Fixable a => (a -> Bool) -> Value a -> Rule -> Rule+conditionalRule cond v (Rule act) = Rule $ addAction v (\x -> if cond x then act else return ())++dynamicRule  :: Fixable a =>  Value a -> (a -> Rule) -> Rule+dynamicRule v dr = Rule $ addAction v (unRule . dr)++propagateValue :: Fixable a => a -> RvValue a -> IO ()+propagateValue p v = do+    if isBottom p then return () else do+    (modifyIORef (todo $ fixer v) (Set.insert $ MkFixable v))+    modifyIORef (pending v) (lub p)+++-- | read result, calculating fixpoint if needed+readValue :: (Fixable a,MonadIO m) => Value a -> m a+readValue (IV v) = liftIO $ do+    findFixpoint Nothing (fixer v)+    readIORef (current v)+readValue (IOValue iov) = liftIO iov >>= readValue+readValue (ConstValue v) = return v+readValue (UnionValue a b) = liftIO $ do+    a' <- readValue a+    b' <- readValue b+    return (lub a' b')++readRawValue :: (Fixable a,MonadIO m) => Value a -> m a+readRawValue (IV v) = liftIO $ do+    readIORef (current v)+readRawValue (IOValue iov) = liftIO iov >>= readRawValue+readRawValue (ConstValue v) = return v+readRawValue (UnionValue a b) = liftIO $ do+    a' <- readRawValue a+    b' <- readRawValue b+    return (lub a' b')++calcFixpoint :: MonadIO m => String -> Fixer -> m ()+calcFixpoint s fixer = findFixpoint (Just (s,stdout)) fixer++-- | find fixpoint, perhaps printing debugging information to specified handle. will not print anything if no calculation needed.+findFixpoint :: MonadIO m => Maybe (String,Handle) ->  Fixer -> m ()+findFixpoint msh@(~(Just (mstring,_))) Fixer { vars = vars, todo = todo } = liftIO $ do+    to <- readIORef todo+    if Set.null to then return () else do+    vars <- readIORef vars+    let f _ tl n | (tl::Int) `seq` n `seq` False = undefined+        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) (0::Int)++++-- some useful instances++instance Ord n => Fixable (Set.Set n)  where+    bottom = Set.empty+    isBottom = Set.null+    lub a b = Set.union a b+    minus a b = a Set.\\ b+++instance Fixable Bool where+    bottom = False+    isBottom x = x == False+    lub a b = a || b+    minus True False = True+    minus False True = False+    minus True True = False+    minus False False = False++-- bottom is zero and the lub is the maximum of integer values, as in this is the lattice of maximum, not the additive one.+instance Fixable Int where+    bottom = 0+    isBottom = (0 ==)+    lub a b = max a b+    minus a b | a > b = a+    minus _ _ = 0++instance (Fixable a,Fixable b) => Fixable (a,b) where+    bottom = (bottom,bottom)+    isBottom (a,b) = isBottom a && isBottom b+    lub (x,y) (x',y') = (lub x x', lub y y')+    minus (x,y) (x',y') = (minus x x', minus y y')+++-- the maybe instance creates a new bottom of nothing. note that (Just bottom) is a distinct point.+instance Fixable a => Fixable (Maybe a) where+    bottom = Nothing+    isBottom Nothing = True+    isBottom _ = False+    lub Nothing b = b+    lub a Nothing = a+    lub (Just a) (Just b) = Just (lub a b)+    minus (Just a) (Just b) = Just (minus a b)+    minus (Just a) Nothing = Just a+    minus Nothing _ = Nothing+
+ src/Fixer/Supply.hs view
@@ -0,0 +1,52 @@+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 view
@@ -0,0 +1,110 @@+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 view
@@ -0,0 +1,255 @@+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+    | 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 rather than curved ones, for compatibility+    | 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 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 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 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 rather than curved ones, for compatibility\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", "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 view
@@ -0,0 +1,122 @@+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+    | FullInt           -- ^ extend Int and Word to 32 bits on a 32 bit machine (rather than 30)+    | GlobalOptimize    -- ^ perform whole program E optimization+    | InlinePragmas     -- ^ use inline pragmas+    | Jgc               -- ^ use the jgc garbage collector+    | Lint              -- ^ perform lots of extra type checks+    | M4                -- ^ pass haskell source through m4 preprocessor+    | MonomorphismRestriction -- ^ enforce monomorphism restriction+    | Negate            -- ^ any particular one by prepending 'no-' to it.+    | 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+    | ViaGhc            -- ^ compile via ghc+    | 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 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 FullInt = "full-int"+    show ViaGhc = "via-ghc"+    show Wrapper = "wrapper"+    show Boehm = "boehm"+    show Jgc = "jgc"+    show Profile = "profile"+    show Debug = "debug"+    show Raw = "raw"++one "profile" = Right $ Set.insert Profile+one "no-profile" = Right $ Set.delete Profile+one "boehm" = Right $ Set.insert Boehm+one "no-boehm" = Right $ Set.delete Boehm+one "jgc" = Right $ Set.insert Jgc+one "no-jgc" = Right $ Set.delete Jgc+one "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 "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 "full-int" = Right $ Set.insert FullInt+one "no-full-int" = Right $ Set.delete FullInt+one "default" = Right $ foldr (.) id [ f | Right f <- [ one "inline-pragmas",one "rules",one "wrapper",one "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 "via-ghc" = Right $ Set.insert ViaGhc+one "no-via-ghc" = Right $ Set.delete ViaGhc+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\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 full-int\n    extend Int and Word to 32 bits on a 32 bit machine (rather than 30)\n jgc\n    use the jgc garbage collector\n profile\n    enable profiling code in generated executable\n raw\n    just evaluate main to WHNF and nothing else.\n via-ghc\n    compile via ghc\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", "full-int", "global-optimize", "inline-pragmas", "jgc", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "via-ghc", "wrapper"]+
+ src/FrontEnd/Class.hs view
@@ -0,0 +1,587 @@+module FrontEnd.Class(+    printClassHierarchy,+    instanceToTopDecls,+    ClassHierarchy,+    ClassRecord(..),+    isClassRecord,+    isClassAliasRecord,+    instanceName,+    defaultInstanceName,+    printClassSummary,+    findClassRecord,+    asksClassRecord,+    classRecords,+    makeClassHierarchy,+    scatterAliasInstances,+    derivableClasses,+    makeInstanceEnv,+    InstanceEnv(..),+    Inst(..)+    ) where++import Data.DeriveTH+import Data.Derive.All+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 Support.MapBinaryInstance+import Maybe+import Monad+import Name.Name+import Name.Names+import Support.CanType+import PrimitiveOperators(primitiveInsts)+import Support.FreeVars+import Util.Gen+import Util.HasSize+import Util.Inst()+import Support.Tickle++--------------------------------------------------------------------------------++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+                                      classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)]+                                    }+                 | ClassAliasRecord { className :: Class,+                                      classSrcLoc :: SrcLoc,+                                      classArgs :: [Tyvar],+                                      classSupers :: [Class],+                                      classInsts :: [Inst],+                                      classClasses :: [Class],+                                      classMethodMap :: Map.Map Name Class  +                                    }+    deriving Show+$(derive makeBinary ''ClassRecord)+$(derive makeIs ''ClassRecord)++newClassRecord c = ClassRecord {+    className = c,+    classSrcLoc = bogusASrcLoc,+    classSupers = [],+    classArgs = [],+    classInsts = [],+    classAssumps = [],+    classAssocs = []+    }++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,+    classArgs = if null (classArgs cra) then classArgs crb else classArgs cra+    }++combineClassRecords cra@(ClassAliasRecord {}) crb@(ClassRecord {}) | className cra == className crb = ClassAliasRecord {+    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,+    classArgs = if null (classArgs cra) then classArgs crb else classArgs cra,+    classClasses = classClasses cra,+    classMethodMap = classMethodMap cra+}++combineClassRecords cra@(ClassRecord {}) crb@(ClassAliasRecord {}) = combineClassRecords crb cra+combineClassRecords cra crb = error ("combineClassRecords ("++show cra++") ("++show crb++")")++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 getMap+    put (ClassHierarchy ch) = putMap 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 ""+    f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do+        putStrLn $ "-- class: " ++ show cname+        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)+        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))+        unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes)+        putStrLn ""++++printClassHierarchy :: ClassHierarchy -> IO ()+printClassHierarchy (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;+            -- possibly absent+            methodAssumps = classAssumps cr+            assocs = classAssocs cr+            classes = classClasses 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)+        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)+        when (isClassAliasRecord cr) $ do+            putStr $ "alias for:"+            pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))+        putStr "\n"+    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+-}++++++qtToClassHead :: KindEnv -> HsQualType -> ([Pred],(Name,[Type]))+qtToClassHead kt (HsQualType cntx (HsTyApp (HsTyCon className) ty)) = (map (hsAsstToPred kt) cntx,(toName ClassName className,[runIdentity $ hsTypeToType kt ty]))++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 _ qualType methods)+    = unzip $ map (methodToTopDecls ch kt [] crecord qualType) $ methodGroups where+    methodGroups = groupEquations methods+    (_,(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 kt ch@(ClassHierarchy classHierarchy) cad@(HsClassAliasDecl {})+   = unzip $ map (aliasDefaultMethodToTopDecls kt methodSigs aliasName) $ methodGroups where+   aliasName = toName ClassName (hsDeclName cad)+   methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) (hsDeclDecls cad))+   methodSigs = case Map.lookup aliasName classHierarchy  of+           Nothing -> error $ "aliasDefaultInstanceToTopDecls: could not find class "+                              ++ show aliasName ++ "in class hierarchy"+           Just sigs -> concatMap (classAssumps . findClassRecord ch) (classClasses 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")+aliasDefaultInstanceName :: Name -> Class -> Name+aliasDefaultInstanceName n ca = toName Val $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ ".default."++show ca)++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 ch kt preds crecord@(ClassAliasRecord {}) qt meth@(methodName, methodDecls) +   = methodToTopDecls ch kt preds (findClassRecord ch cls) qt meth+     where Just cls = Map.lookup methodName (classMethodMap crecord)++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++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++aliasDefaultMethodToTopDecls :: KindEnv -> [Assump] -> Class -> (Name, HsDecl) -> (HsDecl,Assump)+aliasDefaultMethodToTopDecls kt methodSigs aliasName (methodName, methodDecls)+   = (renamedMethodDecls,(newMethodName,sigFromClass)) where+     newMethodName = aliasDefaultInstanceName methodName aliasName+     sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of+         [x] -> x+         _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show  methodName+      --  = newMethodSig cntxt newMethodName sigFromClass argType+     renamedMethodDecls = renameOneDecl newMethodName methodDecls++renameOneDecl :: Name -> HsDecl -> HsDecl+renameOneDecl newName (HsFunBind matches)+   = HsFunBind  (map (renameOneMatch newName) matches)+-- all pattern bindings are simple by this stage+-- (ie no compound patterns)+renameOneDecl newName (HsPatBind sloc (HsPVar patName) rhs wheres)+   = HsPatBind sloc (HsPVar (nameName newName)) rhs wheres++renameOneMatch :: Name -> HsMatch -> HsMatch+renameOneMatch newName (HsMatch sloc oldName pats rhs wheres)+   = HsMatch sloc (nameName newName) pats rhs wheres++++newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> Type -> Sigma+newMethodSig' kt methodName newCntxt qt' instanceType  = newQualType where+    TForAll _ ((IsIn _ classArg:restContext) :=> t) = qt'+    -- the assumption is that the context is non-empty and that+    -- the class and variable that we are interested in are at the+    -- front of the old context - the method of inserting instance types into+    -- the class hierarchy should ensure this+    --((className, classArg):restContxt) = cntxt+    foo = "_" ++ (show methodName ++ show (getTypeHead instanceType)) ++ "@@"+--    newQualType = everywhere (mkT at) $ tForAll (nub $ freeVars qt) qt++    newQualType = tForAll vs nqt where+        vs = nub $ freeVars nqt+        nqt = map (tickle f) (newCntxt ++ restContext) :=> f t+        f t | t == classArg = f instanceType+        f (TVar t) = TVar (at t)+        f (TForAll ta (ps :=> t)) = tickle f (TForAll (map at ta) (ps :=> t))+        f (TExists ta (ps :=> t)) = tickle f (TExists (map at ta) (ps :=> t))+        f t = tickle f t++    at (Tyvar _ n k) =  tyvar (updateName (++ foo) n) k+    updateName f n = toName nt (md,f nm) where+         (nt,(md::String,nm)) = fromName n+--    qt = (newCntxt ++ restContext) :=> t+    {-+    qt = (newCntxt ++ restContext) :=> (everywhere (mkT ct) t)+    ct n | n == classArg = instanceType+    ct n =  n+    -}+++-- collect assumptions of all class methods++classMethodAssumps :: ClassHierarchy -> [Assump]+classMethodAssumps hierarchy = concatMap classAssumps $ classRecords hierarchy++--------------------------------------------------------------------------------++scatterAliasInstances :: ClassHierarchy -> ClassHierarchy+scatterAliasInstances ch =+    let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch]+    --ch `seq` liftIO $ putStrLn ("scatterAliasInstances: " ++ show cas)+        instances = concatMap scatterInstancesOf cas+        ret = foldr (modifyClassRecord $ \cr -> cr +                     { classInsts = [],+                       classMethodMap = Map.fromList [(meth, cls) | cls <- classClasses cr,+                                                                    (meth,_) <- classAssumps (findClassRecord ch cls)]+                     })+                    (ch `mappend` classHierarchyFromRecords instances)+                    (map className cas)+    -- liftIO $ mapM_ print (classRecords ret)+    in ret+    +scatterInstancesOf :: ClassRecord -> [ClassRecord]+scatterInstancesOf cr = map extract (classClasses cr)+    where+      extract c =+          (newClassRecord c) { classInsts = +                                   [Inst sl d ((cxt ++ [IsIn c2 xs | c2 <- classClasses cr, c2 /= c]) :=> IsIn c xs) []+                                        | Inst sl d (cxt :=> IsIn _ xs) [] <- classInsts cr] }++--------------------------------------------------------------------------------++failSl sl m = fail $ show sl ++ ": " ++ m++classHierarchyFromRecords rs = 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 = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], 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@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do+        tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl),+                                 classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)],+                                 classSrcLoc = hsDeclSrcLoc decl,+                                 classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)],+                                 classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)],+                                 classInsts = [],+                                 classMethodMap = Map.empty+                               }]+            +    f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do+        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 view
@@ -0,0 +1,102 @@+{-------------------------------------------------------------------------------++        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 view
@@ -0,0 +1,109 @@+{-------------------------------------------------------------------------------++        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 ++ foldr (++) [] (map getLocalDeclDeps wheres)+getDeclDeps (HsActionDecl _ _ e) = getExpDeps e+getDeclDeps (HsFunBind matches) = foldr (++) [] (map getMatchDeps matches)+getDeclDeps _ = []+++getMatchDeps :: HsMatch -> [HsName]+getMatchDeps (HsMatch _sloc _name _pats rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)++-- get the dependencies from the local definitions in a function++getLocalDeclDeps :: HsDecl -> [HsName]+getLocalDeclDeps (HsFunBind matches) = foldr (++) [] (map getMatchDeps matches)++getLocalDeclDeps (HsPatBind _sloc _hspat rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)+getLocalDeclDeps (HsActionDecl _sloc _ e) = getExpDeps e++getLocalDeclDeps _ = []++-- get the dependencies from the rhs of a function++getRhsDeps :: HsRhs -> [HsName]+getRhsDeps (HsUnGuardedRhs e) = getExpDeps e+getRhsDeps (HsGuardedRhss rhss) = foldr (++) [] (map getGuardedRhsDeps rhss)++getGuardedRhsDeps :: HsGuardedRhs -> [HsName]+getGuardedRhsDeps (HsGuardedRhs _sloc guardExp rhsExp)+   = getExpDeps guardExp ++ getExpDeps rhsExp++++getExpDeps :: HsExp -> [HsName]+getExpDeps e = execWriter (expDeps e)++expDeps (HsVar name) = tell [name]+expDeps (HsLet decls e) = do+    expDeps e+    tell $ foldr (++) [] (map getLocalDeclDeps decls)+expDeps (HsCase e alts) = do+    expDeps e+    tell $ foldr (++) [] (map getAltDeps alts)+expDeps (HsDo stmts) = do+    tell $ foldr (++) [] (map getStmtDeps stmts)+expDeps (HsListComp e stmts) = do+    expDeps e+    tell $ foldr (++) [] (map getStmtDeps stmts)+expDeps e = traverseHsExp_ expDeps e++getAltDeps :: HsAlt -> [HsName]++getAltDeps (HsAlt _sloc _pat guardedAlts wheres)+   = getGuardedAltsDeps guardedAlts +++     foldr (++) [] (map getLocalDeclDeps wheres)++getGuardedAltsDeps :: HsRhs -> [HsName]+getGuardedAltsDeps (HsUnGuardedRhs e) = getExpDeps e++getGuardedAltsDeps (HsGuardedRhss gAlts) = foldr (++) [] (map getGAltsDeps gAlts)++getGAltsDeps :: HsGuardedRhs -> [HsName]+getGAltsDeps (HsGuardedRhs _sloc e1 e2)+   = getExpDeps e1 +++     getExpDeps e2++getStmtDeps :: HsStmt -> [HsName]+getStmtDeps (HsGenerator _srcLoc _pat e) = getExpDeps e++getStmtDeps (HsQualifier e) = getExpDeps e++getStmtDeps (HsLetStmt decls)+   = foldr (++) [] (map getLocalDeclDeps decls)
+ src/FrontEnd/DependAnalysis.hs view
@@ -0,0 +1,290 @@+{-------------------------------------------------------------------------------++        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 view
@@ -0,0 +1,486 @@+{-------------------------------------------------------------------------------++        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 Options+import FrontEnd.Syn.Traverse+import qualified FlagOpts as FO+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 view
@@ -0,0 +1,132 @@+{-------------------------------------------------------------------------------++        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 view
@@ -0,0 +1,142 @@++-- | 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 view
@@ -0,0 +1,63 @@+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 view
@@ -0,0 +1,96 @@+-- |+-- 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 view
@@ -0,0 +1,966 @@+{-# 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 C.FFI+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) } }+      | body                                          { HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (UnQual (HsIdent "main"))], hsModuleImports = (fst $1), hsModuleDecls = (snd $1) } }++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 } }+      | decl          { $1 }+++rule :: { HsRule }+      : srcloc STRING mfreevars exp '=' exp+         { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6 } }++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 view
@@ -0,0 +1,717 @@+-----------------------------------------------------------------------------+--  $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 view
@@ -0,0 +1,446 @@+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 {+    hsRuleUniq :: (Module,Int),+    hsRuleSrcLoc :: SrcLoc,+    hsRuleIsMeta :: Bool,+    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 view
@@ -0,0 +1,329 @@+{-------------------------------------------------------------------------------++        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 Support.MapBinaryInstance+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) = putMap ts+    get = fmap FixityMap getMap++restrictFixityMap :: (Name -> Bool) -> FixityMap -> FixityMap+restrictFixityMap f (FixityMap fm) = FixityMap (Map.filterWithKey (\k _ -> f k) fm)+++----------------------------------------------------------------------------+++ -- Some constants:++syn_err_msg :: String+syn_err_msg = "Syntax error in input, run through a compiler to check.\n"++syn_err_bad_oparg op exp =    syn_err_msg ++ "\tERROR: cannot apply " ++ show op+                           ++ " to the expression: " ++ show exp++syn_err_precedence op exp =    syn_err_msg ++ "\tERROR: the precedence of " ++ show op+                            ++ " is incompatible with the precendence of it's argument: " ++ show exp++defaultFixity :: (Int, HsAssoc)     -- Fixity assigned to operators without explict infix declarations.+defaultFixity = (9, HsAssocLeft)++terminalFixity :: (Int, HsAssoc)    -- Fixity given to variables, etc. Used to terminate descent.+terminalFixity = (10, HsAssocLeft)+++----------------------------------------------------------------------------++  -- infixer(): The exported top-level function. See header for usage.++infixHsModule :: FixityMap -> HsModule -> HsModule+infixHsModule (FixityMap ism) m = hsModuleDecls_u f m where+    f = map (processDecl ism)+    --ism = buildSMap is++infixStatement :: FixityMap -> HsStmt -> HsStmt+infixStatement (FixityMap ism) m = processStmt ism m+++++--infixer :: [HsDecl] -> TidyModule -> TidyModule+--infixer infixRules tidyMod =+--    tidyMod { tidyClassDecls = process tidyClassDecls,+--              tidyInstDecls = process tidyInstDecls,+--              tidyFunBinds = process tidyFunBinds,+--              tidyPatBinds = process tidyPatBinds }+--    where+--        process field = map (processDecl infixMap) (field tidyMod)+--        infixMap = buildSMap infixRules+++----------------------------------------------------------------------------++  --  Functions for building and searching the map of operators and their+  -- associated associativity and binding power.++buildFixityMap :: [HsDecl] -> FixityMap+buildFixityMap ds = FixityMap (Map.fromList $ concatMap f ds)  where+        f (HsInfixDecl _ assoc strength names) = zip (map make_key names) $ repeat (strength,assoc)+        f _ = []+        make_key = fromValishHsName+        --make_key a_name = case a_name of+        --    (Qual a_module name)   -> (a_module, name)+        --    (UnQual name)          -> (unqualModule, name)+++--buildSMap infixRules =+--    foldl myAddToFM emptyFM $ concat $ map formatDecl infixRules+--    where+--        formatDecl (HsInfixDecl _ assoc strength names) = zip (map make_key names) $ circList (strength,assoc)+--        formatDecl _ = []+--        circList (str,assc) = (str,assc) : circList (str,assc)+--        myAddToFM fm (k,e) = addToFM fm k e+--        make_key a_name = case a_name of+--            (Qual a_module name)   -> (a_module, name)+--            (UnQual name)          -> (unqualModule, name)++lookupSM infixMap  exp = case exp of+    HsAsPat _ e -> lookupSM infixMap e+    HsVar qname    -> Map.findWithDefault defaultFixity (toName Val qname) infixMap+    HsCon qname    -> Map.findWithDefault defaultFixity (toName DataConstructor qname) infixMap+    _           -> error $ "Operator (" ++ show exp ++ ") is invalid."++--lookupSM infixMap  exp = case exp of+--    HsAsPat _ e -> lookupSM infixMap e+--    HsVar qname    -> case qname of+--                    Qual a_module name -> lookupDftFM infixMap defaultFixity (a_module, name)+--                    UnQual name        -> lookupDftFM infixMap defaultFixity (unqualModule, name)+--    HsCon qname  -> case qname of+--                    Qual a_module name -> lookupDftFM infixMap defaultFixity (a_module, name)+--                    UnQual name        -> lookupDftFM infixMap defaultFixity (unqualModule, name)+--    _           -> error $ "Operator (" ++ show exp ++ ") is invalid."+++-----------------------------------------------------------------------------++  --  Functions used to sift through the syntax to find expressions to+  -- operate on.++processDecl :: SymbolMap -> HsDecl -> HsDecl+processDecl infixMap decl = case decl of+    HsClassDecl    srcloc qualtype decls   -> HsClassDecl srcloc qualtype $ proc_decls decls+    HsInstDecl     srcloc qualtype decls   -> HsInstDecl srcloc qualtype $ proc_decls decls+    HsFunBind      matches                 -> HsFunBind $ map (processMatch infixMap) matches+    HsPatBind      srcloc pat rhs decls    -> HsPatBind srcloc (procPat infixMap pat) (processRhs infixMap rhs) $ proc_decls decls+    HsPragmaRules rs -> HsPragmaRules $ map proc_rule rs+    _                                       -> decl+    where+        proc_decls decls = map (processDecl infixMap) decls+        proc_rule prules@HsRule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2} =+             prules { hsRuleLeftExpr = fst $ processExp infixMap e1, hsRuleRightExpr = fst $ processExp infixMap e2 }+++processMatch :: SymbolMap -> HsMatch -> HsMatch+processMatch infixMap (HsMatch srcloc qname pats rhs decls) =+    HsMatch srcloc qname (map (procPat infixMap) pats) new_rhs new_decls+    where+        new_rhs = processRhs infixMap rhs+        new_decls = map (processDecl infixMap) decls+++processRhs :: SymbolMap -> HsRhs -> HsRhs+processRhs infixMap rhs = case rhs of+    HsUnGuardedRhs exp     -> HsUnGuardedRhs $ fst $ processExp infixMap exp+    HsGuardedRhss  rhss    -> HsGuardedRhss $ map (processGRhs infixMap) rhss+++processGRhs :: SymbolMap -> HsGuardedRhs -> HsGuardedRhs+processGRhs infixMap (HsGuardedRhs srcloc e1 e2) = HsGuardedRhs srcloc new_e1 new_e2+    where+        new_e1 = fst $ processExp infixMap e1+        new_e2 = fst $ processExp infixMap e2+++processAlt :: SymbolMap -> HsAlt -> HsAlt+processAlt infixMap (HsAlt srcloc pat g_alts decls) = HsAlt srcloc (procPat infixMap pat) new_g_alts new_decls+    where+        new_g_alts = processGAlts infixMap g_alts+        new_decls = map (processDecl infixMap) decls+++processGAlts :: SymbolMap -> HsRhs -> HsRhs+processGAlts infixMap g_alts = case g_alts of+    HsUnGuardedRhs exp     -> HsUnGuardedRhs $ fst $ processExp infixMap exp+    HsGuardedRhss galts    -> HsGuardedRhss $ map (processGAlt infixMap) galts+++processGAlt :: SymbolMap -> HsGuardedRhs -> HsGuardedRhs+processGAlt infixMap (HsGuardedRhs srcloc e1 e2) = HsGuardedRhs srcloc new_e1 new_e2+    where+        new_e1 = fst $ processExp infixMap e1+        new_e2 = fst $ processExp infixMap e2+++processStmt :: SymbolMap -> HsStmt -> HsStmt+processStmt infixMap stmt = case stmt of+    HsGenerator srcloc pat exp     -> HsGenerator srcloc (procPat infixMap pat) $ fst $ processExp infixMap exp+    HsQualifier exp                -> HsQualifier $ fst $ processExp infixMap exp+    HsLetStmt decls                -> HsLetStmt $ map (processDecl infixMap) decls+ -- _                           -> error "Bad HsStmt data passed to processStmt."+++processFUpdt :: SymbolMap -> HsFieldUpdate -> HsFieldUpdate+processFUpdt infixMap (HsFieldUpdate qname exp) = HsFieldUpdate qname new_exp+    where+        new_exp = fst $ processExp infixMap exp+++procPat sm p = fst $ processPat sm p+processPat :: SymbolMap -> HsPat -> (HsPat, FixityInfo)+processPat infixMap exp = case exp of+    HsPInfixApp l op r  ->+              case (compare l_power op_power) of+                    GT -> (HsPInfixApp new_l op new_r, op_fixity)+                    EQ -> case op_assoc of+                        HsAssocNone    -> error_precedence op new_l+                        HsAssocRight   -> case l_assoc of+                            HsAssocRight   -> case new_l of+                                HsPInfixApp l' op' r' -> (HsPInfixApp l' op' (process_r' r'), l_fixity)+                                _                     -> error_syntax op new_l+                            _               -> error_precedence op new_l+                        HsAssocLeft    -> case l_assoc of+                            HsAssocLeft    -> (HsPInfixApp new_l op new_r, op_fixity)+                            _               -> error_precedence op new_l+                    LT -> case new_l of+                        HsPInfixApp l' op' r' -> (HsPInfixApp l' op' (process_r' r'), l_fixity)+                        _                     -> error_syntax op new_l+               where+                    (new_l, l_fixity) = processPat infixMap l+                    l_power = fst l_fixity+                    l_assoc = snd l_fixity+                    op_fixity = Map.findWithDefault defaultFixity  (toName DataConstructor op) infixMap+                    op_power = fst op_fixity+                    op_assoc = snd op_fixity+                    new_r = processExp' r+                    process_r' r' = processExp' $ HsPInfixApp r' op r+                    error_precedence err_op err_lower = error $ syn_err_precedence err_op err_lower+                    error_syntax err_op err_lower = error $ syn_err_bad_oparg err_op err_lower+    x@HsPVar {} -> (x,terminalFixity)+    x@HsPLit {} -> (x,terminalFixity)+    x@HsPWildCard  -> (x,terminalFixity)+    HsPNeg p ->    tf $ HsPNeg (pp p)+    HsPIrrPat p -> tf $ HsPIrrPat (fmap pp p)+    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 view
@@ -0,0 +1,546 @@++-- |+-- 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,+    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 Support.MapBinaryInstance+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 } = putMap a >> putMap b >> putMap c+    get = do+        a <- getMap+        b <- getMap+        c <- getMap+        return KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c }++instance HasSize KindEnv where+    size KindEnv { kindEnv = env } = size env++instance FreeVars Kind [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 constraint ? 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 $ 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 view
@@ -0,0 +1,680 @@+-- #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 view
@@ -0,0 +1,313 @@+-- #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 view
@@ -0,0 +1,474 @@+-- #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"+                tast _ = error "tast!"+--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 view
@@ -0,0 +1,903 @@+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+        m <- getCurrentModule+        i <- newUniq+        return prules {  hsRuleUniq = (m,i), 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 view
@@ -0,0 +1,350 @@+{-+        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,+    MetaVar(..),+    tTTuple,+    tTTuple',+    tList+    )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)++instance Ord (IORef a)+instance Binary (IORef a)++tList = TCon (Tycon tc_List (Kfun kindStar 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++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 t rs = (t,rs)++fromTArrow t = f t [] where+    f (TArrow a b) rs = f b (a:rs)+    f t rs = (reverse rs,t)+++instance CanType MetaVar 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 ''MetaVarType)+$(derive makeBinary ''Type)+$(derive makeBinary ''MetaVar)+$(derive makeBinary ''Tycon)+$(derive makeBinary ''Pred)+$(derive makeBinary ''Qual)
+ src/FrontEnd/SrcLoc.hs view
@@ -0,0 +1,122 @@+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 view
@@ -0,0 +1,54 @@+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 view
@@ -0,0 +1,255 @@+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 view
@@ -0,0 +1,267 @@+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 view
@@ -0,0 +1,7 @@+module FrontEnd.Tc.Class(simplify,FrontEnd.Class.ClassHierarchy) where++import FrontEnd.Class+import FrontEnd.Tc.Type+++simplify :: ClassHierarchy -> [Pred] -> [Pred]
+ src/FrontEnd/Tc/Kind.hs view
@@ -0,0 +1,172 @@+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++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 view
@@ -0,0 +1,919 @@+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 [] 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 { hsRuleUniq = uniq, hsRuleFreeVars = vs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2, hsRuleSrcLoc = sloc } =+    withContext (locMsg sloc "in the RULES pragma" $ hsRuleString prule) ans where+        ans = do+            vs' <- mapM dv vs+            tr <- newBox kindStar+            let (vs,envs) = unzip vs'+            ch <- getClassHierarchy+            ((e1,rs1),(e2,rs2)) <- localEnv (mconcat envs) $ do+                    (e1,ps1) <- listenPreds (tcExpr e1 tr)+                    (e2,ps2) <- listenPreds (tcExpr e2 tr)+                    ([],rs1) <- splitPreds ch [] 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+            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 view
@@ -0,0 +1,282 @@+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 = scatterAliasInstances $ smallClassHierarchy `mappend` importClassHierarchy++    when (dump FD.ClassSummary) $ do+        putStrLn "  ---- class summary ---- "+        printClassSummary cHierarchyWithInstances++    when (dump FD.Class) $+         do {putStrLn "  ---- class hierarchy ---- ";+             printClassHierarchy smallClassHierarchy}++    -- lift the instance methods up to top-level decls++    let cDefBinds = concat [ [ z | z <- ds] | HsClassDecl _ _ ds <- ds]+    let myClassAssumps = concat  [ classAssumps as | as <- classRecords cHierarchyWithInstances, 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 ++  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)+        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) 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 view
@@ -0,0 +1,557 @@+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.Error+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 Util.Inst+import Util.SetLike+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)+++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 view
@@ -0,0 +1,337 @@+module FrontEnd.Tc.Type(+    Kind(..),+    KBase(..),+    MetaVar(..),+    MetaVarType(..),+    Pred(..),+    Preds(),+    Qual(..),+    Tycon(..),+    Type(..),+    Tyvar(..),+    kindStar,+    kindFunRet,+    kindUTuple,+    unfoldKind,+    fn,+    followTaus,+    fromTAp,+    fromTArrow,+    module FrontEnd.Tc.Type,+    prettyPrintType,+    readMetaVar,+    tForAll,+    tList,+    Constraint(..),+    applyTyvarMap,+    Class(),+    Kindvar(..),+    tTTuple,+    tTTuple',+    tyvar+    ) where++import Control.Monad.Identity+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 Name.Names+import Name.VConsts+import FrontEnd.Representation+import Support.CanType+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 view
@@ -0,0 +1,327 @@++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 (TAp a b) (TAp c d) = do+        printRule "APP"+        a `boxyMatch` c+        b `boxyMatch` d+        return False++    -- Associated type+    bm ta@TAssoc {} (TMetaVar mv) = do+        ta' <- evalFullType ta+        if mv `elem` freeVars ta' then do+            printRule "ASSOC-OCCURS"+            addPreds [IsEq ta' (TMetaVar mv)]+         else do+            printRule "ASSOC-BIND"+            varBind mv ta'+        return False++    bm ta@TAssoc {} tb@TAssoc {} = do+        ta' <- evalFullType ta+        tb' <- evalFullType tb+        when (ta' /= tb') $ do+            printRule "ASSOC-EQ"+            addPreds [IsEq ta' tb']+        return False++    bm ta@TAssoc {} t = do+        printRule "ASSOC-EQ"+        -- are associated types tau?+        addPreds [IsEq ta t]+        return False++    -- MEQ1 MEQ2  SYM+    bm a b+        | isTau a, TMetaVar mv <- b = printRule "MEQ1" >> varBind mv a >> return False+        | isTau a && isTau b = printRule "MEQ2" >> unify a b >> return False+    bm _ _ = return True+++solveConstraints :: [Constraint] -> Tc ()+solveConstraints cs = mapM_ f cs where+    f Equality { constraintSrcLoc = _sl, constraintType1 = t1, constraintType2 = t2 } = {- withSrcLoc sl $ -} boxyMatch t1 t2++listenSolvePreds :: Tc a -> Tc (a,[Pred])+listenSolvePreds tc = do+    (x,(ps,cs)) <- listenCPreds tc+    ((),(ps',cs')) <- listenCPreds (solveConstraints cs)+    ch <- getClassHierarchy+    return (x,simplify ch (ps ++ ps') ++ [ IsEq a b | Equality _ a b <- cs' ])+++var_meets_var :: MetaVar -> MetaVar -> Tc ()+var_meets_var tv1 tv2 = do+--    when (getType tv1 /= getType tv2) $ error "BBEQ boxyMatch kinds"+    k <- kindCombine (getType tv1) (getType tv2)+    f k tv1 tv2+    where+    f k tv1 tv2 | tv1 == tv2 = zonkKind k tv1 >> return ()+    f k tv1 tv2 | isBoxyMetaVar tv1 && isBoxyMetaVar tv2 = do+            printRule "BBEQ"+            tt <- newMetaVar Tau k+            varBind tv1 tt+            varBind tv2 tt+    f k tv1 tv2 | isBoxyMetaVar tv1  = do+            printRule "BBEQ-L"+            varBind tv1 (TMetaVar tv2)+            zonkKind k tv2+            return ()+    f k tv1 tv2 | isBoxyMetaVar tv2  = do+            printRule "BBEQ-R"+            varBind tv2 (TMetaVar tv1)+            zonkKind k tv1+            return ()+    f k tv1 tv2  = do+            printRule "BBEQ-Tau"+            varBind tv2 (TMetaVar tv1)+            zonkKind k tv1+            return ()++++unify      :: Tau -> Tau -> Tc ()+unify t1 t2 = do+    t1' <- evalType t1+    t2' <- evalType t2+    printRule $ "unify: " <> ppretty t1' <+> ppretty t2'+    mgu t1' t2'++mgu (TAp l r) (TAp l' r')+   = do s1 <- unify l l'+        s2 <- unify r r'+        return ()+mgu (TArrow l r) (TArrow l' r')+   = do s1 <- unify l l'+        s2 <- unify r r'+        return ()+mgu (TMetaVar u) t | not $ isBoxyMetaVar u = varBind u t+mgu t (TMetaVar u) | not $ isBoxyMetaVar u = varBind u t+mgu (TVar a) (TVar b) | a == b = return ()+mgu c1@(TCon tc1) c2@(TCon tc2)+           | tc1==tc2 = return ()+           -- | otherwise = fail $ "mgu: Constructors don't match:" ++ show (c1,c2)+           | otherwise = unificationError c1 c2+mgu TForAll {} _ = error "attempt to unify TForall"+mgu _ TForAll {} = error "attempt to unify TForall"+mgu t1 t2  = unificationError t1 t2++++-- This is used in pattern matching because it might be polymorphic, but also needs to match exactly+--subsumesPattern a b | isTau b = a `boxyMatch` b+--subsumes+++++
+ src/FrontEnd/TypeSigs.hs view
@@ -0,0 +1,122 @@+{-------------------------------------------------------------------------------++        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 view
@@ -0,0 +1,114 @@++module FrontEnd.TypeSynonyms (+    removeSynonymsFromType,+    declsToTypeSynonyms,+    TypeSynonyms,+    restrictTypeSynonyms,+    showSynonym+    ) where++import Control.Monad.Identity+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+import Support.MapBinaryInstance+++newtype TypeSynonyms = TypeSynonyms (Map.Map Name ([HsName], HsType, SrcLoc))+    deriving(Monoid,HasSize)++instance Binary TypeSynonyms where+    put (TypeSynonyms ts) = putMap ts+    get = fmap TypeSynonyms getMap++restrictTypeSynonyms :: (Name -> Bool) -> TypeSynonyms -> TypeSynonyms+restrictTypeSynonyms f (TypeSynonyms fm) = TypeSynonyms (Map.filterWithKey (\k _ -> f k) fm)++showSynonym :: (DocLike d,Monad m) => (HsType -> d) -> Name -> TypeSynonyms -> m d+showSynonym pprint n (TypeSynonyms m) =+    case Map.lookup n m of+      Just (ns, t, _) -> return $ hsep (tshow n:map tshow ns) <+> text "=" <+> pprint t+      Nothing         -> fail "key not found"++-- | 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 view
@@ -0,0 +1,551 @@+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) = concat $ map getHsNamesAndASrcLocsFromHsDecl hsDecls+++-- the getNew... functions are used only inside class declarations to avoid _re_ renaming things+-- that should be left as is.+++getHsNamesFromHsQualType :: HsQualType -> [HsName]+getHsNamesFromHsQualType (HsQualType _hsContext hsType) = getHsNamesFromHsType hsType++getHsNamesFromHsType :: HsType -> [HsName]+getHsNamesFromHsType (HsTyFun hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)+getHsNamesFromHsType (HsTyTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes+getHsNamesFromHsType (HsTyUnboxedTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes+getHsNamesFromHsType (HsTyApp hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)+getHsNamesFromHsType (HsTyVar hsName) = [hsName]+getHsNamesFromHsType (HsTyForall vs qt) = getHsNamesFromHsQualType qt 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 view
@@ -0,0 +1,80 @@+module FrontEnd.Unlit(unlit) where++-- Part of the following code is from+-- "Report on the Programming Language Haskell",+--   version 1.2, appendix C.+++import Char++data Classified = Program String | Blank | Comment+                | Include Int String | Pre String++classify :: [String] -> [Classified]+classify []                = []+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs+   where allProg [] = []  -- Should give an error message,+                          -- but I have no good position information.+         allProg (('\\':x):xs) |  x == "end{code}" = Blank : classify xs+	 allProg (x:xs) = Program x:allProg xs+classify (('>':x):xs)      = Program (' ':x) : classify xs+classify (('#':'l':'i':'n':'e':' ':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line+                                   -> Include (read line) file+                                _  -> Pre x+                             ) : classify xs+classify (('#':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line+                                   -> Include (read line) file+                                _  -> Pre x+                             ) : classify xs+classify (x:xs) | all isSpace x = Blank:classify xs+classify (x:xs)                 = Comment:classify xs++unclassify :: Classified -> String+unclassify (Program s) = s+unclassify (Pre s)     = '#':s+unclassify (Include i f) = '#':' ':show i ++ ' ':f+unclassify Blank       = ""+unclassify Comment     = ""+++-- | Remove literate comments leaving normal haskell source.++unlit ::+    String      -- ^ Filename for error messages+    -> String   -- ^ literate source+    -> String   -- ^ deliterated source+unlit file lhs = (unlines+                 . map unclassify+                 . adjecent file (0::Int) Blank+                 . classify) (inlines lhs)++adjecent :: String -> Int -> Classified -> [Classified] -> [Classified]+adjecent file 0 _             (x              :xs) = x : adjecent file 1 x xs -- force evaluation of line number+adjecent file n y@(Program _) (x@Comment      :xs) = error (message file n "program" "comment")+adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@(Program _) (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Comment     (x@(Program _)  :xs) = error (message file n "comment" "program")+adjecent file n y@Comment     (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Comment     (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Blank       (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Blank       (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n _             (x@next         :xs) = x: adjecent file (n+1) x xs+adjecent file n _             []                    = []++message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message []     n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message file   n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"+++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+inlines s = lines' s id+  where+  lines' []             acc = [acc []]+  lines' ('\^M':'\n':s) acc = acc [] : lines' s id	-- DOS+  lines' ('\^M':s)      acc = acc [] : lines' s id	-- MacOS+  lines' ('\n':s)       acc = acc [] : lines' s id	-- Unix+  lines' (c:s)          acc = lines' s (acc . (c:))+
+ src/FrontEnd/Utils.hs view
@@ -0,0 +1,54 @@++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 view
@@ -0,0 +1,126 @@+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 view
@@ -0,0 +1,792 @@++--  $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/Grin/Arity.hs view
@@ -0,0 +1,49 @@+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 view
@@ -0,0 +1,213 @@+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+    usedArgs <- newSupply fixer+    usedCafs <- newSupply fixer+    pappFuncs <- newValue fixer bottom+    suspFuncs <- newValue fixer bottom+    -- set all roots as used+    flip mapM_ roots $ \r -> do+        addRule $ value True `implies` sValue usedFuncs r+    let postInline = phaseEvalInlined (grinPhase grin)+++    mapM_ (go fixer pappFuncs suspFuncs usedFuncs usedArgs usedCafs postInline) (grinFuncs grin)+    calcFixpoint "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 Let { expDefs = defs, expBody = body } = do+                mapM_ goAgain [ (name,bod) | FuncDef { funcDefBody = bod, funcDefName = name } <- defs]+                flip mapM_ (map funcDefName defs) $ \n -> do+                    --n' <- supplyValue usedFuncs n+                    --addRule $ fn' `implies` n'+                    return ()+            g Error {} = return ()+            -- TODO - handle function and case return values smartier.+            g (Return ns) = mapM_ (addRule . doNode) ns+            g x = error $ "deadcode.g: " ++ show x+            h' (p,e) = h (p,e) >> return (Just (p,e))+            h (p,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 = implies fn' (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 view
@@ -0,0 +1,121 @@+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++devolveTransform = transformParms {+    transformDumpProgress = True,+    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 view
@@ -0,0 +1,137 @@+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/EvalInline.hs view
@@ -0,0 +1,167 @@+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/FromE.hs view
@@ -0,0 +1,742 @@+module Grin.FromE(compile) where++import Char+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++++{- | 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 }+++{-# 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 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 = 0, tvrType =  a}) b)  =  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 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 tvrIdent b == 0 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 = 0 },EVar etvr) -> 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 = 0 },_) -> 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, tvrIdent x /= 0 ]++    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+        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 (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 = 0, tvrType = a}) b) | 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 =  0, tvrType = x}) y) = 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 :: Monad m =>  E -> m [Val]+literal (ELit LitCons { litName = n, litArgs = xs })  |  Just xs <- mapM literal xs, Just _ <- fromUnboxedNameTuple n = return (keepIts $ concat xs)+literal (ELit (LitInt i ty)) | Just ptype <- toCmmTy ty = return $ [Lit i (TyPrim ptype)]+literal (ELit (LitInt i (ELit (LitCons { litArgs = [], litAliasFor = Just af }))))  = literal $ ELit (LitInt i af)+literal (EPrim 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 view
@@ -0,0 +1,596 @@+{-# 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)]+}+++emptyGrin = Grin {+    grinEntryPoints = mempty,+    grinPhase = PhaseInit,+    grinTypeEnv = mempty,+    grinFunctions = [],+    grinSuspFunctions = mempty,+    grinPartFunctions = mempty,+    grinStats = mempty,+    grinCafs = mempty+}++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 view
@@ -0,0 +1,7 @@+module Grin.Grin where+++data Exp+data Grin+data Val+data Lam
+ src/Grin/HashConst.hs view
@@ -0,0 +1,52 @@+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/Interpret.hs view
@@ -0,0 +1,190 @@+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 view
@@ -0,0 +1,214 @@+{-# 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 __GLASGOW_HASKELL__ >= 610+        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/NodeAnalyze.hs view
@@ -0,0 +1,295 @@++-- 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 Control.Monad.Identity(runIdentity)+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 "-- NodeAnayze"+    (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 view
@@ -0,0 +1,238 @@+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 = 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 view
@@ -0,0 +1,210 @@++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+++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+    putStrLn "Speculatable:"+    mapM_ Prelude.print ss+    let (grin',stats) = runStatM (performSpeculate ss grin)+    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/SSimplify.hs view
@@ -0,0 +1,234 @@+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.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 -> IO Grin+simplify grin = do+    let (fs,_,SCol { colStats = stats}) = runRWS fun mempty SState { usedVars = mempty }+        S fun = simpFuncs (grinFunctions grin)+    return grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats }+++simpFuncs :: [FuncDef] -> S [FuncDef]+simpFuncs fd = do+    let f fd@FuncDef { funcDefBody = body } = do+            body' <- simpLam body+            return $ updateFuncDefProps fd { funcDefBody = body' }+    mapM f fd++simpLam :: Lam -> S Lam+simpLam (ps :-> e) = do+    (ps,env') <- renamePattern ps+    let f col = col { colFreeVars = colFreeVars col 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 view
@@ -0,0 +1,202 @@+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,nmap)+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 Name.VConsts+import Cmm.Number+import Options+import Support.CanType+import Support.FreeVars+import Util.Graphviz+import qualified Cmm.Op as Op+import qualified FlagDump as FD++++instance DocLike d => PPrint d 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 x = text x+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 :: DocLike d => Val -> d+prettyVal s | Just [] <- valToList s = text "[]"+prettyVal s | Just st <- fromVal s = text $ show (st::String)+prettyVal s | Just vs <- valToList s = list $ map prettyVal vs+prettyVal (NodeC 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 view
@@ -0,0 +1,9 @@+module Grin.Show where++import Doc.Pretty+import Atom+import {-# SOURCE #-} Grin.Grin++prettyFun :: (Atom.Atom,Grin.Grin.Lam) -> Doc.Pretty.Doc+prettyExp :: Doc.Pretty.Doc -> Grin.Grin.Exp -> Doc.Pretty.Doc+prettyVal :: Grin.Grin.Val -> Doc.Pretty.Doc
+ src/Grin/Simplify.hs view
@@ -0,0 +1,697 @@+module Grin.Simplify(simplify,renameUniqueGrin) where++import Char+import Control.Monad.Identity+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 C.Prims+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++-- 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 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 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/Unboxing.hs view
@@ -0,0 +1,120 @@+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 view
@@ -0,0 +1,116 @@+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 view
@@ -0,0 +1,209 @@+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 view
@@ -0,0 +1,55 @@+module Ho.Binary() where+++import Control.Monad+import Data.Binary++import Ho.Type+import Support.MapBinaryInstance+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+	    putMap ae+	    put af+	    put ag+	    put ah+	    put ai+	    put ak+	    put al+	    put am+    get = do+    ae <- getMap+    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+	    putMap ad+    get = do+    ac <- get+    ad <- getMap+    return (HoExp ac ad)+
+ src/Ho/Build.hs view
@@ -0,0 +1,717 @@+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.Show+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 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.Digest.Pure.MD5 as MD5+import qualified Codec.Binary.UTF8.String as UTF8+++--+-- 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 reverse f of+                   ('s':'h':'.':_)     -> Right f+                   ('s':'h':'l':'.':_) -> 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.newGraph  [ ((m,sourceHash sc),fs (sourceHash sc)) | (m,Found sc) <- Map.toList (modEncountered done)] (fst . fst) snd+        gr' = G.sccGroups gr+        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__=" ++ revision):[ "-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 view
@@ -0,0 +1,81 @@+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 view
@@ -0,0 +1,93 @@+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 view
@@ -0,0 +1,120 @@+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 Support.MapBinaryInstance()+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 view
@@ -0,0 +1,85 @@+module Info.Binary(putInfo, Info.Binary.getInfo) where++import Data.Dynamic+import qualified Data.Map as Map+import Data.Word++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 view
@@ -0,0 +1,7 @@+module Info.Binary where++import Info.Info+import Data.Binary++putInfo :: Info.Info.Info -> Put+getInfo :: Get Info.Info.Info
+ src/Info/Info.hs view
@@ -0,0 +1,163 @@+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)++instance Data Info where+    toConstr = undefined+    dataTypeOf = undefined++instance Monoid Info where+    mempty = empty+    mappend (Info as) (Info bs) = Info (List.union as bs)++class HasInfo a where+    getInfo :: a -> Info+    modifyInfo :: (Info -> Info) -> a -> a++instance HasInfo Info where+    getInfo = id+    modifyInfo f x = f x++lookupTyp :: forall a . Typeable a => a -> Info -> Maybe a+lookupTyp a = f where+    f (Info mp) = g mp+    typ = typeOf (undefined :: a)+    g [] = Nothing+    g (x:xs) | entryType x == typ = fromDynamic (entryThing x)+    g (_:xs) = g xs+++lookup :: forall a m . (Monad m,Typeable a) => Info -> m a+lookup = maybe (fail $ "Info: could not find: " ++ show typ) return . f where+    typ = typeOf (undefined :: a)+    f = lookupTyp (undefined :: a)++++insertWith :: (Show a,Typeable a) => (a -> a -> a) -> a -> Info -> Info+insertWith f newx (Info mp) = Info (g mp) where+    g [] = [newEntry newx]+    g (x:xs) | entryType x == typ = newEntry (f newx (fromDyn (entryThing x) (error "can't happen"))):xs+             | otherwise = x:g xs+    typ = typeOf newx+++newEntry :: (Typeable a,Show a) => a -> Entry+newEntry x = Entry { entryThing = toDyn x, entryString = show x, entryType = typeOf x }+++insert :: (Show a,Typeable a) => a -> Info -> Info+insert newx (Info nfo) = Info $ newEntry newx:f nfo where+    f [] = []+    f (x:xs) | entryType x == typ = xs+             | otherwise = x:f xs+    typ = typeOf newx++maybeInsert :: (Show a, Typeable a) => Maybe a -> Info -> Info+maybeInsert Nothing = id+maybeInsert (Just x) = insert x++singleton :: (Show a,Typeable a) => a -> Info+singleton x = insert x empty++infoMapM :: (Typeable a, Typeable b, Show b, Monad m) => (a -> m b) -> Info -> m Info+infoMapM f i = case Info.Info.lookup i of+    Just x -> do+        n <- f x+        return (insert n (delete x i))+    Nothing -> return i++infoMap :: (Typeable a, Typeable b, Show b) => (a -> b) -> Info ->  Info+infoMap f i = case Info.Info.lookup i of+    Just x -> insert (f x) (delete x i)+    Nothing -> i++delete :: (Typeable a) => a -> Info -> Info+delete x info = deleteTyp (typeOf x) info++deleteTyp :: TypeRep -> Info -> Info+deleteTyp typ (Info mp) = Info (f mp) where+    f [] = []+    f (x:xs) | entryType x == typ = xs+             | otherwise = x:f xs++limit :: [TypeRep] -> Info -> Info+limit trs (Info mp) = Info (f mp) where+    f (x:xs) | entryType x `elem` trs = x:f xs+             | otherwise = f xs+    f [] = []++fetch :: (Monoid a, Typeable a) => Info -> a+fetch info = maybe mempty id  (Info.Info.lookup info)++member :: (Typeable a) => a -> Info -> Bool+member x (Info s) = f s where+    typ = typeOf x+    f [] = False+    f (x:xs) | entryType x == typ = True+             | otherwise = f xs++extend :: (Show a,Monoid a, Typeable a) => a -> Info -> Info+extend x info = insertWith mappend x info++empty :: Info+empty = Info []+
+ src/Info/Properties.hs view
@@ -0,0 +1,63 @@+module Info.Properties where++data Property = PROP_INLINE | PROP_MULTISPECIALIZE | PROP_NOINLINE | PROP_SRCLOC_ANNOTATE | PROP_SUPERINLINE | PROP_NOETA | PROP_CYCLIC | PROP_EXPORTED | PROP_INSTANCE | PROP_JOINPOINT | PROP_METHOD | PROP_ONESHOT | PROP_PLACEHOLDER | PROP_RULEBINDER | PROP_SCRUTINIZED | PROP_SPECIALIZATION | PROP_SRCLOC_ANNOTATE_FUN | PROP_SUPERSPECIALIZE | PROP_UNSHARED | PROP_WHNF | PROP_WORKER | PROP_WRAPPER | PROP_HASRULE+    deriving(Eq,Ord,Enum,Bounded)++instance Show Property where+   show PROP_INLINE = "INLINE"+   show PROP_MULTISPECIALIZE = "MULTISPECIALIZE"+   show PROP_NOINLINE = "NOINLINE"+   show PROP_SRCLOC_ANNOTATE = "SRCLOC_ANNOTATE"+   show PROP_SUPERINLINE = "SUPERINLINE"+   show PROP_NOETA = "NOETA"+   show PROP_CYCLIC = "_CYCLIC"+   show PROP_EXPORTED = "_EXPORTED"+   show PROP_INSTANCE = "_INSTANCE"+   show PROP_JOINPOINT = "_JOINPOINT"+   show PROP_METHOD = "_METHOD"+   show PROP_ONESHOT = "_ONESHOT"+   show PROP_PLACEHOLDER = "_PLACEHOLDER"+   show PROP_RULEBINDER = "_RULEBINDER"+   show PROP_SCRUTINIZED = "_SCRUTINIZED"+   show PROP_SPECIALIZATION = "_SPECIALIZATION"+   show PROP_SRCLOC_ANNOTATE_FUN = "_SRCLOC_ANNOTATE_FUN"+   show PROP_SUPERSPECIALIZE = "_SUPERSPECIALIZE"+   show PROP_UNSHARED = "_UNSHARED"+   show PROP_WHNF = "_WHNF"+   show PROP_WORKER = "_WORKER"+   show PROP_WRAPPER = "_WRAPPER"+   show PROP_HASRULE = "_HASRULE"+++{-# NOINLINE readProp #-}+readProp "INLINE" = return PROP_INLINE+readProp "MULTISPECIALIZE" = return PROP_MULTISPECIALIZE+readProp "NOINLINE" = return PROP_NOINLINE+readProp "SRCLOC_ANNOTATE" = return PROP_SRCLOC_ANNOTATE+readProp "SUPERINLINE" = return PROP_SUPERINLINE+readProp "NOETA" = return PROP_NOETA+readProp p = fail $ "Invalid Property: " ++ p++prop_INLINE = PROP_INLINE+prop_MULTISPECIALIZE = PROP_MULTISPECIALIZE+prop_NOINLINE = PROP_NOINLINE+prop_SRCLOC_ANNOTATE = PROP_SRCLOC_ANNOTATE+prop_SUPERINLINE = PROP_SUPERINLINE+prop_NOETA = PROP_NOETA+prop_CYCLIC = PROP_CYCLIC+prop_EXPORTED = PROP_EXPORTED+prop_INSTANCE = PROP_INSTANCE+prop_JOINPOINT = PROP_JOINPOINT+prop_METHOD = PROP_METHOD+prop_ONESHOT = PROP_ONESHOT+prop_PLACEHOLDER = PROP_PLACEHOLDER+prop_RULEBINDER = PROP_RULEBINDER+prop_SCRUTINIZED = PROP_SCRUTINIZED+prop_SPECIALIZATION = PROP_SPECIALIZATION+prop_SRCLOC_ANNOTATE_FUN = PROP_SRCLOC_ANNOTATE_FUN+prop_SUPERSPECIALIZE = PROP_SUPERSPECIALIZE+prop_UNSHARED = PROP_UNSHARED+prop_WHNF = PROP_WHNF+prop_WORKER = PROP_WORKER+prop_WRAPPER = PROP_WRAPPER+prop_HASRULE = PROP_HASRULE
+ src/Info/Types.hs view
@@ -0,0 +1,64 @@+-- | 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/Interactive.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}+module Interactive(Interactive.interact) where++import Control.Monad.Reader+import Control.Monad.Identity+import Control.Monad.Trans+import Control.Exception as CE+import Data.Monoid+import IO(stdout)+import List(sort)+import Maybe+import Monad+import qualified Data.Map as Map+import qualified Text.PrettyPrint.ANSI.Leijen as PP+import Text.Regex+--import Text.Regex.Posix(regcomp,regExtended)+++import DataConstructors+import Doc.DocLike+import Doc.PPrint+import Doc.Pretty+import FrontEnd.HsParser(parseHsStmt)+import FrontEnd.KindInfer+import FrontEnd.ParseMonad+import FrontEnd.Rename+import FrontEnd.Tc.Main+import FrontEnd.Tc.Monad+import FrontEnd.Tc.Type+import FrontEnd.Tc.Class+import FrontEnd.Desugar(desugarHsStmt)+import GenUtil+import Ho.Type+import Ho.Collected+import FrontEnd.HsPretty()+import FrontEnd.HsSyn+import Name.Name+import Options+import qualified FrontEnd.Infix+import qualified FrontEnd.HsPretty as HsPretty+import FrontEnd.TypeSynonyms(showSynonym)+import FrontEnd.TypeSyns+import FrontEnd.TypeSigs+import Util.Interact+import LHCVersion(versionString)+import FrontEnd.Warning++printDoc doc = do+    displayIO stdout (renderPretty 0.9 80 doc)+    putStrLn ""++grep_opts = [+ "f - match normal value",+ "C - match data constructor",+ "T - match type constructor",+ "L - match class"+ ]++nameTag :: NameType -> Char+nameTag TypeConstructor = 'T'+nameTag DataConstructor = 'C'+nameTag ClassName = 'L'+nameTag Val = 'f'+nameTag _ = '?'++data InteractiveState = IS {+    stateHo :: HoBuild,+    stateInteract :: Interact,+    stateModule :: Module,+    stateImports :: [(Name,[Name])],+    stateOptions :: Opt+    }++isInitial = IS {+    stateHo = mempty,+    stateInteract = emptyInteract,+    stateModule = Module "Main",+    stateImports = [],+    stateOptions = options+    }+++newtype In a = MkIn (ReaderT InteractiveState IO a)+    deriving(MonadIO,Monad,Functor,MonadReader InteractiveState)++runIn :: InteractiveState -> In a -> IO a+runIn is (MkIn x) = runReaderT x is++instance OptionMonad In where+    getOptions = asks stateOptions++instance MonadWarn In where+    addWarning x = liftIO $ addWarning x++++interact :: CollectedHo -> IO ()+interact cho = mre where+    hoE = hoExp $ choHo cho+    hoB = hoBuild $ choHo cho++    mre = case optStmts options of+        [] -> go+        xs -> runInteractions initialInteract (concatMap lines $ reverse xs) >> exitSuccess+    go = do+        putStrLn "--------------------------------------------------------------"+        putStrLn "Welcome to the lhc interactive experience. use :help for help."+        putStrLn versionString+        putStrLn "--------------------------------------------------------------"+        runInteraction initialInteract ":execfile lhci.rc"+        beginInteraction initialInteract+    initialInteract = emptyInteract {+        interactSettables = ["prog", "args"],+        interactVersion = versionString,+        interactCommands = commands,+        interactWords = map (show . fst ) $ stateImports isStart,+        interactComment = Just "--",+        interactExpr = do_expr+        }+    dataTable = hoDataTable hoB+    commands = [cmd_mods,cmd_grep]+    cmd_mods = InteractCommand { commandName = ":mods", commandHelp = "mods currently loaded modules", commandAction = do_mods }+    do_mods act _ _ = do+        printDoc $ fillSep (map tshow $ Map.keys $  hoExports hoE)+        return act+    cmd_grep = InteractCommand { commandName = ":grep", commandHelp = "show names matching a regex", commandAction = do_grep }+    do_grep act _ "" = do+        putStrLn ":grep [options] <regex>"+        putStrLn "Valid options:"+        putStr $ unlines grep_opts+        return act+    do_grep act _ arg = do+        let (opt,reg) = case simpleUnquote arg of+                [x] -> ("TCLf",x)+                xs -> f "" xs where+            f opt [x] = (opt,x)+            f opt ~(x:xs) = f (x ++ opt) xs+#if __GLASGOW_HASKELL__ >= 610+        rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException) -> return Nothing)+#else+        rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\_ -> return Nothing)+#endif+        case rx of+            Nothing -> putStrLn $ "Invalid regex: " ++ arg+            --Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v <+> "::" <+> ptype v  | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]+            Just rx -> mapM_ putStrLn $ sort [ pshow opt v  | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]+        return act+    ptype x | Just r <- pprintTypeOfCons dataTable x = r+    ptype k | Just r <- Map.lookup k (hoAssumps hoB) = show (pprint r:: PP.Doc)+    ptype x | nameType x == ClassName = hsep (map kindShow $ kindOfClass x (hoKinds hoB))+    ptype x = "UNKNOWN: " ++ show (nameType x,x)+    isStart =  isInitial { stateHo = hoB, stateImports = runIdentity $ calcImports hoE False (Module "Prelude") }+    do_expr :: Interact -> String -> IO Interact+    do_expr act s = case parseStmt (s ++ "\n") of+        Left m -> putStrLn m >> return act+        Right e -> do+#if __GLASGOW_HASKELL__ >= 610+            CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException))+#else+            CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show e)+#endif+            return act+    pshow _opt v+        | Just d <- showSynonym (show . (pprint :: HsType -> PP.Doc) ) v (hoTypeSynonyms hoB) = nameTag (nameType v):' ':d+        | otherwise = nameTag (nameType v):' ':show v <+> "::" <+> ptype v++kindShow (KBase b) = pprint b+kindShow x = parens (pprint x)++parseStmt ::  Monad m => String -> m HsStmt+parseStmt s = case runParserWithMode (parseModeOptions options) { parseFilename = "(lhci)" } parseHsStmt  s  of+                      ParseOk _ e -> return e+                      ParseFailed sl err -> fail $ show sl ++ ": " ++ err++printStatement stmt = do+        liftIO $ putStrLn $ HsPretty.render $ HsPretty.ppHsStmt $  stmt++procErrors :: In a -> In ()+procErrors act = do+    b <- liftIO $ printIOErrors+    if b then return () else act >> return ()+++executeStatement :: HsStmt -> In ()+executeStatement stmt = do+    is@IS { stateHo = hoB } <- ask+    stmt <- desugarHsStmt stmt+    stmt' <- renameStatement mempty (stateImports is) (stateModule is) stmt+    procErrors $ do+    --printStatement stmt'+    stmt'' <- expandTypeSynsStmt (hoTypeSynonyms hoB) (stateModule is) stmt'+    stmt''' <- return $ FrontEnd.Infix.infixStatement (hoFixities hoB) stmt''+    procErrors $ do+    printStatement stmt'''+    tcStatementTc stmt'''++{-+tcStatement :: HsStmt -> In ()+tcStatement HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"+tcStatement HsGenerator {} = liftIO $ putStrLn "generators not yet supported"+tcStatement (HsQualifier e) = do+    tcStatementTc (HsQualifier e)+    when False $ do+    is@IS { stateHo = ho } <- ask+    let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == Val ]+        importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x ==  DataConstructor ]+        ansName = Qual (stateModule is) (HsIdent "ans")+        ansName' = toName Val ansName+    opt <- getOptions+    localVarEnv <- liftIO $ TI.tiProgram+                opt                            -- options+                (stateModule is)               -- name of the module+                mempty                         -- environment of type signatures+                (hoKinds ho)                   -- kind information about classes and type constructors+                (hoClassHierarchy ho)          -- class hierarchy with instances+                importDConsEnv                 -- data constructor type environment+                importVarEnv                   -- type environment+                [([],[HsPatBind bogusASrcLoc (HsPVar ansName) (HsUnGuardedRhs e) []])]                        -- binding groups+                []+    procErrors $ do+    vv <- Map.lookup ansName' localVarEnv+    liftIO $ putStrLn $ show (text "::" <+> pprint vv :: P.Doc)+    -}+++tcStatementTc :: HsStmt -> In ()+tcStatementTc HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"+tcStatementTc HsGenerator {} = liftIO $ putStrLn "generators not yet supported"+tcStatementTc (HsQualifier e) = do+    is@IS { stateHo = ho } <- ask+    let tcInfo = tcInfoEmpty {+        tcInfoEnv = (hoAssumps ho),+        tcInfoSigEnv =  collectSigEnv (hoKinds ho) (HsQualifier e),+        tcInfoModName =  show (stateModule is),+        tcInfoKindInfo = (hoKinds ho),+        tcInfoClassHierarchy = (hoClassHierarchy ho)++        }+    runTc tcInfo $ do+    box <- newBox kindFunRet+    (_,ps') <- listenPreds $ tiExpr e box+    ps' <- flattenType ps'+    let ps = FrontEnd.Tc.Class.simplify (hoClassHierarchy ho) ps'+    (ps :=> vv) <- flattenType (ps :=> box)+    TForAll vs (ps :=> t) <- generalize ps vv -- quantify (tv vv) qt+    --liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)+    liftIO $ putStrLn $   "::" <+> prettyPrintType (TForAll vs (ps :=> t))+    ce <- getCollectedEnv+    liftIO $ mapM_ putStrLn [ pprint n <+>  "::" <+> prettyPrintType s |  (n,s) <- Map.toList ce]+++calcImports :: Monad m => HoExp -> Bool -> Module -> m [(Name,[Name])]+calcImports ho qual mod = case Map.lookup mod (hoExports ho) of+    Nothing -> fail $ "calcImports: module not known " ++ show mod+    Just es -> do+        let ls = sortGroupUnderFG fst snd+                [ (n,if qual then [setModule mod n] else [setModule mod n,toUnqualified n]) | n <- es]+            ls' = concat [ zip (concat nns) (repeat [n]) | (n,nns) <- ls ]+        return $ Map.toList $ Map.map snub $ Map.fromListWith (++) ls'+
+ src/LHCVersion.hs view
@@ -0,0 +1,20 @@+-- | 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            = "kami"+version        = showVersion P.version+shortVersion   = concat $ intersperse "." $ map show $ init $ versionBranch P.version+revision       = show $ tail $ 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/Main.hs view
@@ -0,0 +1,974 @@+{-# LANGUAGE CPP #-}+module Main(main) where++import Control.Exception+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 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 Interactive+import qualified Stats+import qualified System.IO as IO++#if __GLASGOW_HASKELL__ >= 610+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 = True++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 = do -- runMain $ catom $ bracketHtml $ 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+    int <- isInteractive+    when (not int) $ 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 reverse f of+                   ('s':'h':'.':_)     -> Right f+                   ('s':'h':'l':'.':_) -> 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 _ -> k /= emptyId) 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]+    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 ]++    -- Build rules from instances, specializations, and user specified rules and catalysts+    let instanceRules = createInstanceRules fullDataTable (hoClassHierarchy $ hoBuild ho')  (ds `mappend` hoEs (hoBuild ho))+    -- FIXME: 'converRules' 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 = 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 = programFloatInward } mprog+        mprog <- 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 = programFloatInward+        } prog++    prog <- 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 = programFloatInward } mprog+        mprog <- Demand.analyzeProgram mprog+        mprog <- simplifyProgram sopt "Simplify-Two" coreMini mprog+        mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog+        mprog <- Demand.analyzeProgram mprog+        mprog <- return $ E.CPR.cprAnalyzeProgram mprog+        mprog' <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "WorkWrap", transformOperation = return . workWrapProgram } mprog+        let wws = length (programDs mprog') - length (programDs mprog)+        liftIO $ wdump FD.Progress $ putErr (replicate wws 'w')+        mprog <- return mprog'++        mprog <- simplifyProgram sopt "Simplify-Three" coreMini mprog++        --mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog+        --mprog <- Demand.analyzeProgram mprog+        --mprog <- return $ E.CPR.cprAnalyzeProgram mprog+        --mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "WorkWrap2", transformOperation = return . workWrapProgram } mprog+        --mprog <- simplifyProgram sopt "Simplify-Four" coreMini mprog+++        -- annotate our bindings for further passes+        mprog <- return $ etaAnnotateProgram mprog+        mprog <- Demand.analyzeProgram mprog+        mprog <- return $ E.CPR.cprAnalyzeProgram mprog++        put $ fromList [ (combIdent c,c) | c <- progCombinators mprog] `S.union` smap++        liftIO $ wdump FD.Progress $ let SubProgram rec = progType mprog in  putErr (if rec then "*" else ".")+        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++isInteractive :: IO Bool+isInteractive = do+    pn <- System.getProgName+    return $ (optMode options == Interactive)+          || "ichj" `isPrefixOf` reverse pn+          || not (null $ optStmts options)++transTypeAnalyze = transformParms { transformCategory = "typeAnalyze",  transformOperation = typeAnalyze True }++compileModEnv cho = do+    if optMode options == CompileHo 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.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'++    -- enter interactive mode+    int <- isInteractive+    if int then Interactive.interact cho else do++    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++    (viaGhc,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 = if viaGhc then 1 else 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 $ printProgram prog+    prog <- if (fopts FO.TypeAnalysis) then do typeAnalyze False prog else return prog+    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 $ 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+        exitSuccess+++    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterMethod", transformDumpProgress = True } 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 <- 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++    when viaGhc $ do+        wdump FD.Core $ printProgram prog+        fail "Compiling to GHC currently disabled"+        --compileToHs prog+        exitSuccess++    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+++-- | 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 :: Program -> IO 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) | v /= 0, v `notMember` freeIds e = f (ELam t { tvrIdent = 0 } e)+    f (EPi t@TVr { tvrIdent = v } e) | v /= 0, v `notMember` freeIds e = f (EPi t { tvrIdent = 0 } e)+    f ec@ECase { eCaseBind = t@TVr { tvrIdent = v } } | v /= 0, v `notMember` (freeVars (caseBodies ec)::IdSet) = f ec { eCaseBind = t { tvrIdent = 0 } }+    f e = emapEG f f e++simplifyParms = transformParms {+    transformDumpProgress = verbose,+    transformCategory = "Simplify",+    transformPass = "Grin",+    transformOperation = 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 prog+    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 <- 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 <- 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+    x <- 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+    compileGrinToC x+++dumpFinalGrin grin = do+    wdump FD.GrinGraph $ do+        let dot = graphGrin grin+            fn = optOutName options+        writeFile (fn ++ "_grin.dot") dot+    dumpGrin "final" grin++++compileGrinToC grin | optMode options == Interpret = fail "Interpretation currently not supported."+compileGrinToC grin | optMode options /= CompileExe = return ()+compileGrinToC grin = 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=2", "-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 ++ optCCargs options  ++ boehmOpts ++ profileOpts+        debug = if fopts FO.Debug then ["-g"] else ["-DNDEBUG", "-O3", "-fomit-frame-pointer"]+        globalvar n c = "char " ++ n ++ "[] = \"" ++ c ++ "\";"+    writeFile cf $ unlines [globalvar "lhc_c_compile" comm, globalvar "lhc_command" argstring,globalvar "lhc_version" sversion,"",cg]+    progress ("Running: " ++ comm)+    r <- System.system comm+    when (r /= System.ExitSuccess) $ fail "C code did not compile."+    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 __GLASGOW_HASKELL__ >= 610+        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 $ isValidAtom 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/Binary.hs view
@@ -0,0 +1,29 @@+module Name.Binary() where++import Maybe+import Data.Monoid++import Data.Binary+import Name.Id+import Name.Name+++instance Binary IdSet where+    put ids = do+        put [ id | id <- idSetToList ids, isNothing (fromId id)]+        put [ n | id <- idSetToList ids, n <- fromId id]+    get = do+        (idl:: [Id])   <- get+        (ndl:: [Name]) <- get+        return (idSetFromDistinctAscList idl `mappend` idSetFromList (map toId ndl))+++instance Binary a => Binary (IdMap a) where+    put ids = do+        put [ x | x@(id,_) <- idMapToList ids, isNothing (fromId id)]+        put [ (n,v) | (id,v) <- idMapToList ids, n <- fromId id]+    get = do+        idl <- get+        ndl <- get+        return (idMapFromDistinctAscList idl `mappend` idMapFromList [ (toId n,v) | (n,v) <- ndl ])+
+ src/Name/Id.hs view
@@ -0,0 +1,203 @@+module Name.Id(+    Id(),+    IdMap(),+    IdNameT(),+    IdSet(),+    addBoundNamesIdMap,+    addBoundNamesIdSet,+    addNamesIdSet,+    idMapToIdSet,+    idNameBoundNames,+    idNameUsedNames,+    etherialIds,+    isEtherialId,+    isInvalidId,+    idSetToIdMap,+    mapMaybeIdMap,+    idSetFromList,+    idToInt,+    idSetFromDistinctAscList,+    idMapFromList,+    idMapFromDistinctAscList,+    idSetToList,+    idMapToList,+    emptyId,+    newIds,+    newId,+    runIdNameT',+    runIdNameT+    )where++import Control.Monad.State+import Control.Monad.Reader+import Data.Traversable+import Data.Foldable+import Data.Monoid+import Data.Typeable+import System.Random+import Data.Bits+import qualified Data.IntMap  as IM+import qualified Data.IntSet as IS++import StringTable.Atom+import Util.HasSize+import Util.Inst()+import Util.NameMonad+import Util.SetLike as S+import Name.Name++-- TODO - make this a newtype+type Id = Int+-- data Id = Etherial Int | NoBind | Named Name | Unnamed Int++-- IdSet+++newtype IdSet = IdSet IS.IntSet+    deriving(Typeable,Monoid,HasSize,SetLike,BuildSet Id,ModifySet Id,IsEmpty,Eq,Ord)+++idSetToList :: IdSet -> [Id]+idSetToList (IdSet is) = IS.toList is++idMapToList :: IdMap a -> [(Id,a)]+idMapToList (IdMap is) = IM.toList is++idToInt :: Id -> Int+idToInt = id++mapMaybeIdMap :: (a -> Maybe b) -> IdMap a -> IdMap b+mapMaybeIdMap fn (IdMap m) = IdMap (IM.mapMaybe fn m)+++-- IdMap++newtype IdMap a = IdMap (IM.IntMap a)+    deriving(Typeable,Monoid,HasSize,SetLike,BuildSet (Id,a),MapLike Id a,Functor,Traversable,Foldable,IsEmpty,Eq,Ord)+++idSetToIdMap :: (Id -> a) -> IdSet -> IdMap a+idSetToIdMap f (IdSet is) = IdMap $ IM.fromDistinctAscList [ (x,f x) |  x <- IS.toAscList is]++idMapToIdSet :: IdMap a -> IdSet+idMapToIdSet (IdMap im) = IdSet $ (IM.keysSet im)+++-- | Name monad transformer.+newtype IdNameT m a = IdNameT (StateT (IdSet, IdSet) m a)+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)++instance (MonadReader r m) => MonadReader r (IdNameT m) where+	ask       = lift ask+	local f (IdNameT m) = IdNameT $ local f m++-- | Get bound and used names+idNameBoundNames :: Monad m => IdNameT m IdSet+idNameBoundNames = IdNameT $ do+    (_used,bound) <- get+    return bound+idNameUsedNames :: Monad m => IdNameT m IdSet+idNameUsedNames = IdNameT $  do+    (used,_bound) <- get+    return used++-- | Run the name monad transformer.+runIdNameT :: (Monad m) => IdNameT m a -> m a+runIdNameT (IdNameT x) = liftM fst $ runStateT x (mempty,mempty)++runIdNameT' :: (Monad m) => IdNameT m a -> m (a,IdSet)+runIdNameT' (IdNameT x) = do+    (r,(used,bound)) <- runStateT x (mempty,mempty)+    return (r,bound)++fromIdNameT (IdNameT x) = x++instance Monad m => NameMonad Id (IdNameT m) where+    addNames ns = IdNameT $ do+        modify (\ (used,bound) -> (fromList ns `union` used, bound) )+    addBoundNames ns = IdNameT $ do+        let nset = fromList ns+        modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )+    uniqueName n = IdNameT $ do+        (used,bound) <- get+        if n `member` bound then fromIdNameT newName else put (insert n used,insert n bound) >> return n+    newNameFrom vs = IdNameT $ do+        (used,bound) <- get+        let f (x:xs)+                | x `member` used = f xs+                | otherwise = x+            f [] = error "newNameFrom: finite list!"+            nn = f vs+        put (insert nn used, insert nn bound)+        return nn+    newName  = IdNameT $ do+        (used,bound) <- get+        let genNames i = [st, st + 2 ..]  where+                st = abs i + 2 + abs i `mod` 2+        fromIdNameT $ newNameFrom  (genNames (size used + size bound))++addNamesIdSet nset = IdNameT $ do+    modify (\ (used,bound) -> (nset `union` used, bound) )+addBoundNamesIdSet nset = IdNameT $ do+    modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )++addBoundNamesIdMap nmap = IdNameT $ do+    modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where+        nset = idMapToIdSet nmap++idSetFromDistinctAscList :: [Id] -> IdSet+idSetFromDistinctAscList ids = IdSet (IS.fromDistinctAscList ids)++idSetFromList :: [Id] -> IdSet+idSetFromList ids = IdSet (IS.fromList ids)++idMapFromList :: [(Id,a)] -> IdMap a+idMapFromList ids = IdMap (IM.fromList ids)++idMapFromDistinctAscList :: [(Id,a)] -> IdMap a+idMapFromDistinctAscList ids = IdMap (IM.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 = [-2, -4 ..  ]++isEtherialId id = id < 0++isInvalidId id = id <= 0++emptyId :: Id+emptyId = 0+++-- | find some temporary ids that are not members of the set,+-- useful for generating a small number of local unique names.++newIds :: IdSet -> [Id]+newIds ids = [ i | i <- [s, s + 2 ..] , i `notMember` ids ] where+    s = 2 + (2 * 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 mask $ randoms (mkStdGen seed)+    mask x = x .&. 0x0FFFFFFE++++
+ src/Name/Name.hs view
@@ -0,0 +1,185 @@+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++data NameType =+    TypeConstructor+    | DataConstructor+    | ClassName+    | TypeVal+    | Val+    | SortName+    | FieldLabel+    | RawType+    deriving(Ord,Eq,Enum,Read,Show)+++newtype Name = Name Atom+    deriving(Ord,Eq,Typeable,Binary,ToAtom,FromAtom)++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 = Name $  toAtom $ (chr $  ord '1' + fromEnum t):m ++ ";" ++ i+createUName :: NameType -> String -> Name+createUName _ "" = error $ "createUName: empty ident"+createUName t i =  Name $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i++class ToName a where+    toName :: NameType -> a -> Name+    fromName :: Name -> (NameType, a)++instance ToName 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+++nameType :: Name -> NameType+nameType (Name a) = toEnum $ fromIntegral ( a `unsafeByteIndex` 0)  - ord '1'++nameName :: Name -> HsName+nameName (Name a) = f $ tail (fromAtom a) where+    f (';':xs) = UnQual $ HsIdent xs+    f xs | (a,_:b) <- span (/= ';') xs  = Qual (Module a) (HsIdent b)+    f _ = error $ "invalid Name: " ++ (show $ (fromAtom a :: String))++nameParts :: Name -> (NameType,Maybe String,String)+nameParts n@(Name a) = f $ tail (fromAtom a) where+    f (';':xs) = (nameType n,Nothing,xs)+    f xs = (nameType 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)++toId :: Name -> Int+toId x = fromAtom (toAtom x)++fromId :: Monad m => Int -> m Name+--fromId i | even i || i < 0 = fail $ "Name.fromId: not a name " ++ show i+--fromId i | not $ isValidAtom i = fail $ "Name.fromId: not a name " ++ show i+fromId i = case intToAtom i of+    Just a -> return $ Name a+    Nothing -> fail $ "Name.fromId: not a name " ++ show i++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 view
@@ -0,0 +1,112 @@+-- | 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 view
@@ -0,0 +1,339 @@+module Name.Prim where++import Name.Name++{-# NOINLINE tc_Int #-}+tc_Int = toName TypeConstructor ("Lhc.Prim","Int")+{-# NOINLINE dc_Int #-}+dc_Int = toName DataConstructor "Int#"+{-# NOINLINE tc_Integer #-}+tc_Integer = toName TypeConstructor ("Lhc.Basics","Integer")+{-# NOINLINE dc_Integer #-}+dc_Integer = toName DataConstructor "Integer#"+{-# NOINLINE tc_Int8 #-}+tc_Int8 = toName TypeConstructor ("Data.Int","Int8")+{-# NOINLINE dc_Int8 #-}+dc_Int8 = toName DataConstructor "Int8#"+{-# NOINLINE tc_Int16 #-}+tc_Int16 = toName TypeConstructor ("Data.Int","Int16")+{-# NOINLINE dc_Int16 #-}+dc_Int16 = toName DataConstructor "Int16#"+{-# NOINLINE tc_Int32 #-}+tc_Int32 = toName TypeConstructor ("Data.Int","Int32")+{-# NOINLINE dc_Int32 #-}+dc_Int32 = toName DataConstructor "Int32#"+{-# NOINLINE tc_Int64 #-}+tc_Int64 = toName TypeConstructor ("Data.Int","Int64")+{-# NOINLINE dc_Int64 #-}+dc_Int64 = toName DataConstructor "Int64#"+{-# NOINLINE tc_IntMax #-}+tc_IntMax = toName TypeConstructor ("Data.Int","IntMax")+{-# NOINLINE dc_IntMax #-}+dc_IntMax = toName DataConstructor "IntMax#"+{-# NOINLINE tc_IntPtr #-}+tc_IntPtr = toName TypeConstructor ("Data.Int","IntPtr")+{-# NOINLINE dc_IntPtr #-}+dc_IntPtr = toName DataConstructor "IntPtr#"+{-# NOINLINE tc_Word #-}+tc_Word = toName TypeConstructor ("Data.Word","Word")+{-# NOINLINE dc_Word #-}+dc_Word = toName DataConstructor "Word#"+{-# NOINLINE tc_Word8 #-}+tc_Word8 = toName TypeConstructor ("Data.Word","Word8")+{-# NOINLINE dc_Word8 #-}+dc_Word8 = toName DataConstructor "Word8#"+{-# NOINLINE tc_Word16 #-}+tc_Word16 = toName TypeConstructor ("Data.Word","Word16")+{-# NOINLINE dc_Word16 #-}+dc_Word16 = toName DataConstructor "Word16#"+{-# NOINLINE tc_Word32 #-}+tc_Word32 = toName TypeConstructor ("Data.Word","Word32")+{-# NOINLINE dc_Word32 #-}+dc_Word32 = toName DataConstructor "Word32#"+{-# NOINLINE tc_Word64 #-}+tc_Word64 = toName TypeConstructor ("Data.Word","Word64")+{-# NOINLINE dc_Word64 #-}+dc_Word64 = toName DataConstructor "Word64#"+{-# NOINLINE tc_WordMax #-}+tc_WordMax = toName TypeConstructor ("Data.Word","WordMax")+{-# NOINLINE dc_WordMax #-}+dc_WordMax = toName DataConstructor "WordMax#"+{-# NOINLINE tc_WordPtr #-}+tc_WordPtr = toName TypeConstructor ("Data.Word","WordPtr")+{-# NOINLINE dc_WordPtr #-}+dc_WordPtr = toName DataConstructor "WordPtr#"+{-# NOINLINE tc_CChar #-}+tc_CChar = toName TypeConstructor ("Foreign.C.Types","CChar")+{-# NOINLINE dc_CChar #-}+dc_CChar = toName DataConstructor "CChar#"+{-# NOINLINE tc_CShort #-}+tc_CShort = toName TypeConstructor ("Foreign.C.Types","CShort")+{-# NOINLINE dc_CShort #-}+dc_CShort = toName DataConstructor "CShort#"+{-# NOINLINE tc_CInt #-}+tc_CInt = toName TypeConstructor ("Foreign.C.Types","CInt")+{-# NOINLINE dc_CInt #-}+dc_CInt = toName DataConstructor "CInt#"+{-# NOINLINE tc_CUInt #-}+tc_CUInt = toName TypeConstructor ("Foreign.C.Types","CUInt")+{-# NOINLINE dc_CUInt #-}+dc_CUInt = toName DataConstructor "CUInt#"+{-# NOINLINE tc_CSize #-}+tc_CSize = toName TypeConstructor ("Foreign.C.Types","CSize")+{-# NOINLINE dc_CSize #-}+dc_CSize = toName DataConstructor "CSize#"+{-# NOINLINE tc_CWchar #-}+tc_CWchar = toName TypeConstructor ("Foreign.C.Types","CWchar")+{-# NOINLINE dc_CWchar #-}+dc_CWchar = toName DataConstructor "CWchar#"+{-# NOINLINE tc_CWint #-}+tc_CWint = toName TypeConstructor ("Foreign.C.Types","CWint")+{-# NOINLINE dc_CWint #-}+dc_CWint = toName DataConstructor "CWint#"+{-# NOINLINE tc_CTime #-}+tc_CTime = toName TypeConstructor ("Foreign.C.Types","CTime")+{-# NOINLINE dc_CTime #-}+dc_CTime = toName DataConstructor "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_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 view
@@ -0,0 +1,116 @@+module Name.VConsts where++import Data.Traversable+import Data.Foldable+import Control.Applicative+import Data.Monoid+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 view
@@ -0,0 +1,323 @@+{-# 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.+          | Interactive    -- ^ Run interactively.+          | Version        -- ^ Print version and die.+          | ShowHelp       -- ^ Show help message and die.+          | Interpret      -- ^ Interpret.+          | CompileHo      -- ^ Compile ho+          | CompileHoGrin  -- ^ Compile ho and grin+          | CompileExe     -- ^ Compile 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).+    optStmts       ::  [String],  -- ^ statements to execute+    optFOpts       ::  [String],  -- ^ Flag options (raw).+    optIncdirs     ::  [String],  -- ^ Include directories.+    optProgArgs    ::  [String],  -- ^ Arguments to pass to the interpreted program.+    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        = CompileExe,+    optColumns     = getColumns,+    optDebug       = False,+    optIncdirs     = initialIncludes,+    optHls         = [],+    optHlPath      = initialLibIncludes,+    optIncs        = [],+    optDefs        = [],+    optProgArgs    = [],+    optDump        = [],+    optStale       = [],+    optStmts       = [],+    optFOpts       = ["default"],+    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 []    ["arg"]       (ReqArg (\d -> optProgArgs_u (++ [d])) "arg") "arguments to pass interpreted program"+    , Option ['N'] ["noprelude"] (NoArg  (optPrelude_s False))         "no implicit prelude"+    , Option ['C'] []            (NoArg  (optMode_s CompileHoGrin))    "Typecheck, compile ho and grin."+    , Option ['c'] []            (NoArg  (optMode_s CompileHo))        "Typecheck and compile ho."+    , Option []    ["interpret"] (NoArg  (optMode_s Interpret))        "interpret."+    , 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 ['e'] []            (ReqArg (\d -> optStmts_u (d:)) "<statement>")  "run given statement as if on lhci prompt"+    , 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 []    ["interactive"] (NoArg  (optMode_s Interactive))    "run interactivly"+    , 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"]+        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 view
@@ -0,0 +1,439 @@+{-# 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.Array.IO+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 qualified Codec.Binary.UTF8.String as UTF8+import Bits+import GHC.Exts+import Data.Array.Base+import Word+import Data.Monoid+import Foreign.C.Types++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 view
@@ -0,0 +1,1181 @@++{- 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+++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 = 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 4 t1+    tvrb =  tVr 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 2 t+    tvrb' = tVr 4 tInt+    tvra = tVr 6 st+    tvrb = tVr 8 intt+    tvrc = tVr 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 2 t+    tvrb' = tVr 4 t+    tvra = tVr 6 st+    tvrb = tVr 8 st+    tvrc = tVr 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 2 t+    tvra = tVr 6 st+    tvrc = tVr 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 2 t+    tvrb' = tVr 4 t+    tvra = tVr 6 st+    tvrb = tVr 8 st+    tvrc = tVr 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 2 st+    tvrb = tVr 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 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 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 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 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 2 (tPtr t))+    tvr' = tVr 4 (rawType "bits<ptr>")+    tvrWorld2 = tVr 258 tWorld__+    tvrWorld = tVr 256 tWorld__+    rtVar = tVr 260 (rawType p)+    rtVar' = tVr 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 2 (tPtr t))+    v_tvr = tVr 4 t+    ptr_tvr' =  (tVr 6 (rawType "bits<ptr>"))+    v_tvr' = tVr 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 258 tWorld__+    tvrWorld = tVr 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 2 tInt+v2_Integer = tVr 2 tInteger+v2 t = tVr 2 t++v0 t = tVr 0 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_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_Data_Word_Word = ELit litCons { litName = tc_Word, litType = eStar}+t_Lhc_Basics_Integer = ELit litCons { litName = tc_Integer, litType = eStar}+t_Data_Int_Int16 = ELit litCons { litName = tc_Int16, litType = eStar}+t_Lhc_Prim_Int = ELit litCons { litName = tc_Int, 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_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_Data_Word_Word = TCon (Tycon tc_Word kindStar)+tc_Lhc_Basics_Integer = TCon (Tycon tc_Integer kindStar)+tc_Data_Int_Int16 = TCon (Tycon tc_Int16 kindStar)+tc_Lhc_Prim_Int = TCon (Tycon tc_Int 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_Order_Eq = toClassName "Lhc.Order.Eq"+n_Lhc_Order_Ord = toClassName "Lhc.Order.Ord"+n_Lhc_Num_Integral = toClassName "Lhc.Num.Integral"+n_Data_Bits_Bits = toClassName "Data.Bits.Bits"+n_Lhc_Num_Num = toClassName "Lhc.Num.Num"+n_Foreign_Storable_Storable = toClassName "Foreign.Storable.Storable"+n_Lhc_Enum_Bounded = toClassName "Lhc.Enum.Bounded"++{-# NOINLINE n_Lhc_Order_Eq #-}+{-# NOINLINE n_Lhc_Order_Ord #-}+{-# NOINLINE n_Lhc_Num_Integral #-}+{-# NOINLINE n_Data_Bits_Bits #-}+{-# NOINLINE n_Lhc_Num_Num #-}+{-# NOINLINE n_Foreign_Storable_Storable #-}+{-# NOINLINE n_Lhc_Enum_Bounded #-}++++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 view
@@ -0,0 +1,40 @@+module RawFiles where+import System.IO.Unsafe+import System.Directory+import System.FilePath+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 viaghc_hs #-}+viaghc_hs :: String+viaghc_hs = readf "ViaGhc.hs"++{-# NOINLINE prelude_m4 #-}+prelude_m4 :: String+prelude_m4 = readf "prelude.m4"++-- convenience+readf = unsafePerformIO . readFile . unsafePerformIO . getDataFileName
+ src/Stats.hs view
@@ -0,0 +1,266 @@+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     | dump FD.SquareStats = C.lTee ++ C.hLine+                   | otherwise           = C.lTee ++ [chr 0x2574]+        lastBranch | dump FD.SquareStats = C.llCorner ++ C.hLine+                   | otherwise           = [chr 0x2570, chr 0x2574]+        +        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 view
@@ -0,0 +1,293 @@+{-# 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.Concurrent.MVar+import Control.Monad+import Data.Bits+import Data.Char+import Data.List+import Data.Word+import System+import System.IO+import System.IO.Unsafe+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as Map+++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 view
@@ -0,0 +1,17 @@+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 view
@@ -0,0 +1,29 @@++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/MapBinaryInstance.hs view
@@ -0,0 +1,39 @@+{-+ We can't use the standard instances for serializing maps containing+ Atoms or Ids. Atoms are compared using their unique  id which depends+ on the order in which they were created. This completely invalidates+ the standard map instances which rely on+ 'fromAscDistinctList . toAscDistinctList = id' to be true.+ Once we've gotten rid of StringTable.Atoms, we can get rid of this+ module as well.+-}+module Support.MapBinaryInstance where+++import Data.Binary+import Data.Word+import Data.Map as Map+import Data.Set as Set+import Control.Monad++putMap :: (Binary k,Ord k,Binary v) => Map.Map k v -> Put+putMap x = do+        put (fromIntegral $ Map.size x :: Word32)+        mapM_ put (Map.toList x)+getMap :: (Binary k,Ord k,Binary v) => Get (Map.Map k v)+getMap = do+        sz <- get :: Get Word32+        ls <- replicateM (fromIntegral sz) get+        return (Map.fromList ls)+++putSet :: (Binary a,Ord a) => Set.Set a -> Put+putSet x = do+        put (fromIntegral $ Set.size x :: Word32)+        mapM_ put (Set.toList x)++getSet :: (Binary a,Ord a) => Get (Set.Set a)+getSet = do+        sz <- get :: Get Word32+        ls <- replicateM (fromIntegral sz) get+        return (Set.fromList ls)
+ src/Support/ShowTable.hs view
@@ -0,0 +1,24 @@+module Support.ShowTable where++import 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 view
@@ -0,0 +1,16 @@+module Support.Tickle where++import Control.Monad.Identity+import Control.Monad.Writer+++class Tickleable a b where+    tickleM :: Monad m => (a -> m a) -> b -> m b+    tickleM_ :: Monad m => (a -> m c) -> b -> m ()+    tickle :: (a -> a) -> b -> b++    tickle f x = runIdentity $ tickleM (return . f) x+    tickleM_ f b = tickleM (\x -> f x >> return x) b >> return ()++tickleCollect :: (Tickleable a b, Monoid o) => (a -> o) -> b -> o+tickleCollect f b = execWriter (tickleM_ (tell . f) b)
+ src/Support/Transform.hs view
@@ -0,0 +1,35 @@+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 view
@@ -0,0 +1,25 @@+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 view
@@ -0,0 +1,180 @@+module Support.Unparse(Unparse(), Unparsable(..), unparse, unparse', Side(..), atom, atomize, bop, pop, fixitize) where++import Doc.DocLike++data Unparse a = Atom a | Pre a (Unparse a) | Fix (Unparse a) a (Unparse a) !Side !Int | Atomized (Unparse a) | Fixitized  !Side !Int (Unparse a)++data Side = R | L | N+    deriving(Eq)++atom :: a -> Unparse a+atom s = Atom s++atomize :: Unparse a -> Unparse a+atomize (Atomized x) = Atomized x+atomize (Atom a) = Atom a+atomize x = Atomized x++fixitize :: (Side,Int) -> Unparse a -> Unparse a+fixitize (s,i) a = Fixitized s i a++pop :: a -> Unparse a -> Unparse a+pop = Pre++bop :: (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a+bop (s,i) op a b = Fix a op b s i+++data Unparsable a = Unparsable {+    unparseGroup :: a -> a,+    unparseCat :: a -> a -> a+    }++data Fix = FAtom | FPre | FFix !Side !Int++unparse :: DocLike a => Unparse a -> a+unparse up = unparse' Unparsable { unparseGroup = parens, unparseCat = (<>) } up++unparse' :: Unparsable a -> Unparse a -> a+unparse' Unparsable { unparseGroup = upg, unparseCat = (<>) } up = fst $ f up where+    f (Atom a) = atom a+    f (Atomized a) = (fst $ f a, FAtom)+    f (Fixitized s i a) = (fst $ f a, FFix s i)+    f (Pre a up) = pop a (f up)+    f (Fix a op b s i) = bop (s,i) op (f a) (f b)++    bop (f1,f2) s (a,FAtom) (b,FAtom)  = (sop s a b, FFix f1 f2)+    bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, FFix f1 f2)+    bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b+    bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))+    bop _ _ _ _ = error "bop"++    pop s (x, FAtom) = ( s <> x, FPre)+    pop s x = pop s $ mkatom x++    atom a = (a,FAtom)+    mkatom (a,FAtom) = (a,FAtom)+    mkatom (a,_) = ( upg a , FAtom)++    sop op a b = a <> (op <> b)++    lts :: Side -> (Side,Int) -> Fix -> Bool+    lts _ _ FAtom = True+    lts _ _ FPre = True+    lts _ (_,n') (FFix  _ n ) | n' /= n = n' < n+    lts R (R,_) (FFix  R _ ) = True+    lts L (L,_) (FFix  L _ ) = True+    lts _ _ _ = False+++++++--lts _ (N,_) (Fix (N,_)) = False++++--type Unparse a = (a, Fix)++{-++bop :: Unparsable a => (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a+--bop f "" a b@(_,Pre) = bop f "" a (mkatom b)+bop (f1,f2) s (a,Atom) (b,Atom)  = (sopns s a b, Fix f1 f2)+bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, Fix f1 f2)+bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b+bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))++pop :: Unparsable a => a -> Unparse a -> Unparse a+pop s (x, Atom) = (unparseCat s  x, Pre)+pop s x = pop s $ mkatom x++++--sop "" a b = a ++ " " ++ b+sop op a b = unparseSpace a $ unparseSpace op b+--sopns "" a b = a ++ " " ++ b+sopns op a b = unparseCat a $ unparseCat op b++mkatom (a,Atom) = (a,Atom)+mkatom (a,_) = ( unparseGroup a , Atom)+--sop "" a b = a ++ " " ++ b+sop op a b = unparseSpace a $ unparseSpace op b+--sopns "" a b = a ++ " " ++ b+sopns op a b = unparseCat a $ unparseCat op b++mkatom (a,Atom) = (a,Atom)+mkatom (a,_) = ( unparseGroup a , Atom)++instance Unparsable Doc where+    unparseCat  =  (<>)+    unparseSpace  =  (<>)+    unparseGroup  = parens+class Unparsable a where+    unparseGroup :: a -> a+    unparseCat :: a -> a -> a+    unparseSpace :: a -> a -> a+    unparseConcat :: [a] -> a+    unparseConcat = foldl1 unparseCat++instance Unparsable String where+    unparseGroup x = "(" ++ x ++ ")"+    unparseCat x y =  x ++ y+    unparseSpace x y = x ++ " " ++ y+    unparseConcat xs = concat xs+++instance Unparsable () where+    unparseGroup _ = ()+    unparseCat _ _ = ()+    unparseSpace _ _ = ()+infixr 9  .+infixr 8  ^, ^^, **+infixl 7  *, /, `quot`, `rem`, `div`, `mod`+infixl 6  +, -++-- The (:) operator is built-in syntax, and cannot legally be given+-- a fixity declaration; but its fixity is given by:+--   infixr 5  :++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||+infixl 1  >>, >>=+infixr 1  =<<+infixr 0  $, $!, `seq`++a + b * c+a + (b * c)++d + a * b + c * d++plus = bop ((L,6)) "+"+minus = bop ((L,6)) "-"+times = bop ((L,7)) "*"+pow = bop ((L,8)) "^"+eq = bop ((N,4)) "=="+++a,b,c,d,x,y, abcdr, abcdl, eql :: (String, Fix)++a = text "a"+b = text "b"+c = text "c"+d = text "d"+x = text "x"+y = text "y"++abcdr = foldl1 plus [a,b,c,d]+abcdl = foldr1 plus [a,b,c,d]+eql = foldl1 eq [a,b,c]++z = eq (plus a b) (pow (times b c) abcdl) `eq` eql+++g = minus (plus (times (plus a b) (plus b c)) abcdr) abcdl+++main = putStrLn $ fst $ foldl1 plus [g,eql, z ]+-}
+ src/Util/ArbitraryInstances.hs view
@@ -0,0 +1,25 @@+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 view
@@ -0,0 +1,86 @@+{-# 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)++++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++instance (Enum a,Show a) => Show (EnumBitSet a) where+    showsPrec n bs = showsPrec n (toList bs)+++toWord :: BitSet -> Word+toWord (BitSet w) = w++fromWord :: Word -> BitSet+fromWord w = BitSet w+
+ src/Util/BooleanSolver.hs view
@@ -0,0 +1,246 @@+-- straightforward linear time solver for boolean constraints.++module Util.BooleanSolver(+    CA(),+    CV(..),+    fromCA,+    readValue,+    groundConstraints,+    processConstraints,+    C(),+    Result(..),+    mkCA,+    equals,+    implies++    )where++import Monad+import Data.IORef+import Control.Monad.Trans+import Util.UnionFind+import Data.List(intersperse)+import Data.Monoid+import Data.Typeable+import qualified Data.Set as Set+import qualified Data.Map as Map+import Util.UnionFind as UF+import Data.FunctorM++++type Seq x = [x] -> [x]++newtype C v = C (Seq (CL v))+    deriving(Monoid)+++instance Functor C where+    fmap f (C v) = C (map (fmap f) (v []) ++)++data CV v = CFalse | CTrue | CJust v+    deriving(Eq,Ord,Typeable)++++data CL v = CV v `Cimplies` CV v+    deriving(Eq,Ord)++instance (Show l) => Show (C l) where+    showsPrec _ (C xs) = showString "(" . foldr (.) id (intersperse (showString ",") (map shows (xs []))) . showString ")"++instance Functor CL where+    fmap f (x `Cimplies` y) = fmap f x `Cimplies` fmap f y++instance FunctorM CL where+    fmapM f (x `Cimplies` y) = return Cimplies `ap` (fmapM f x) `ap` (fmapM f y)+++instance Functor CV where+    fmap f (CJust x) = CJust (f x)+    fmap _ CTrue = CTrue+    fmap _ CFalse = CFalse++instance FunctorM CV where+    fmapM f (CJust x) = liftM CJust (f x)+    fmapM _ CTrue = return CTrue+    fmapM _ CFalse = return CFalse++++instance Show v => Show (CV v) where+    showsPrec n (CJust v) = showsPrec n v+    showsPrec _ CTrue = showString "T"+    showsPrec _ CFalse = showString "F"++++++instance (Show e) => Show (CL e) where+    showsPrec d (CJust x `Cimplies` CJust y) = showParen (d > 9) $ showsPrec 10 x . showString " -> " . showsPrec 10 y+    showsPrec d (CTrue `Cimplies` CJust y) = showParen (d > 9) $ showsPrec 10 y . showString " := T"+    showsPrec d (CJust x `Cimplies` CFalse) = showParen (d > 9) $ showsPrec 10 x . showString " := F"+    showsPrec d (x `Cimplies` y) = showParen (d > 9) $ showsPrec 10 x . showString " -> " . showsPrec 10 y++++-- basic constraints++implies,equals :: CV v -> CV v -> C v+implies x y = C ((x `Cimplies` y):)+equals x y = (x `implies` y) `mappend` (y `implies` x)+++-- a variable is either set to a value or bounded by other values+data Ri a = Ri (Set.Set (RS a))  (Set.Set (RS a))++type R a = CV (Ri a)++type RS a = (Element (R a) a)++newtype CA v = CA (RS v)++fromCA :: CA v -> v+fromCA (CA e) = fromElement e++readValue :: MonadIO m => CA v -> m (Result (CA v))+readValue (CA v) = liftIO $ do+    v <- find v+    w <- getW v+    case w of+        CTrue -> return ResultJust { resultValue = True }+        CFalse -> return ResultJust { resultValue = False }+        (CJust (Ri x y)) -> do+            x <- findSet x+            y <- findSet y+            return (ResultBounded (CA v) (map CA $ Set.toList x) (map CA $ Set.toList y))++++findSet :: Set.Set (Element a b) -> IO (Set.Set (Element a b))+findSet xs = mapM find (Set.toList xs) >>= return . Set.fromList+++mkCA :: MonadIO m => v -> m (CA v)+mkCA v = do liftM CA $ new (CJust (Ri mempty mempty)) v+++groundConstraints :: (MonadIO m,Ord v) => C v -> m (C (CA v), Map.Map v (CA v))+groundConstraints (C cs) = liftIO $ do+    ref <- newIORef mempty+    let ccs = cs []+        nv v = do+            r <- readIORef ref+            case Map.lookup v r of+                Just v -> return v+                Nothing -> do+                    e <- liftM CA $ new (CJust (Ri mempty mempty)) v+                    writeIORef ref (Map.insert v e r)+                    return e+    v <- fmapM (fmapM nv) ccs+    rr <- readIORef ref+    return (C (v ++),rr)++++processConstraints :: (Show v,MonadIO m)+    => Bool      -- ^ whether to propagate subset/superset info. if you only care about fixed results you don't need to do this. if you care about residual constraints and equivalance classes after solving then you should set this.+    -> C (CA v)  -- ^ the input+    -> m ()+processConstraints propagateSets (C cs) = mapM_ prule (cs []) where+    prule (CFalse `Cimplies` _) = return ()+    prule (_ `Cimplies` CTrue) = return ()+    prule (CTrue `Cimplies` CFalse) = fail "invalid constraint: T -> F"+    prule (CTrue `Cimplies` CJust (CA y)) = find y >>= set Nothing True+    prule (CJust (CA x) `Cimplies` CFalse) = find x >>= set Nothing False+    prule (CJust (CA x) `Cimplies` CJust (CA y)) | x == y = return ()+    prule (CJust (CA x) `Cimplies` CJust (CA y)) = do x <- find x; y <- find y; pimp x y+    pimp' :: (MonadIO m,Show a) => RS a -> RS a -> m ()+    pimp' x y = do x <- find x; y <- find y; pimp x y+    pimp x y | x == y = return ()+    pimp x y = do+        xv <- getW x+        yv <- getW y+        case (xv,yv) of+            (CJust ra,CJust rb) -> liftIO $ implies x y ra rb+            (CFalse,_) -> return ()+            (_,CTrue) -> return ()+            (CTrue,CFalse) -> fail $ "invalid constraint T -> F: " ++ show x ++ " -> " ++ show y+            (CTrue,CJust _) -> set (Just x) True y+            (CJust _,CFalse) -> set (Just y) False x++    set mu b xe = do+        w <- getW xe+        case (w,b) of+            (CTrue,True) -> return ()+            (CFalse,False) -> return ()+            (CJust (Ri _ sh),True) -> do putW xe CTrue; mapM_ (set mu True) (Set.toList sh)+            (CJust (Ri sl _),False) -> do putW xe CFalse; mapM_ (set mu False) (Set.toList sl)+            _ -> fail $ "invalid constrant: " ++ show xe ++ " := " ++ show b+        fmapM_ (union const xe) mu++    implies :: (MonadIO m,Show a) => RS a -> RS a -> Ri a -> Ri a -> m ()+    implies xe ye ra rb = do+        ra@(Ri xl xh) <- findRi xe ra+        rb@(Ri yl yh) <- findRi ye rb+        if xe `Set.member` yh then liftIO $ equals xe ye ra rb else do+        if xe `Set.member` yl then return () else do+        if ye `Set.member` xl then liftIO $ equals xe ye ra rb else do+        if ye `Set.member` xh then return () else do+        putW xe (CJust $ Ri xl (Set.insert ye xh))+        putW ye (CJust $ Ri (Set.insert xe yl) yh)+        when propagateSets $ mapM_ (pimp' xe) (Set.toList yh)+        when propagateSets $ mapM_ (flip pimp' ye) (Set.toList xl)+        return ()+    findRi x (Ri l h) = do+        l <- liftM Set.fromList (mapM find (Set.toList l))+        h <- liftM Set.fromList (mapM find (Set.toList h))+        return (Ri l h)+    equals xe ye (Ri xl xh) (Ri yl yh) = do+        let nl = (xl `mappend` yl)+        let nh = (xh `mappend` yh)+        union (\ _ _ -> CJust (Ri nl nh)) xe ye+        when propagateSets $ do+            Ri nl nh <- findRi xe (Ri nl nh)+            putW xe (CJust $ Ri nl nh)+            let eq = Set.intersection nl nh+            flip mapM_ (Set.toList eq) $ \ne -> do+                ne <- find ne+                CJust ri <- getW ne+                ri <- findRi ne ri+                equals xe ne (Ri nl nh) ri+            return ()+        return () :: IO ()+++++data Result a =+    ResultJust {+        resultValue :: Bool+    }+    | ResultBounded {+        resultRep :: a,+        resultLB ::[a],+        resultUB ::[a]+    }+++instance Functor Result where+    fmap f (ResultBounded x ys zs) = ResultBounded (f x) (map f ys) (map f zs)+    fmap f (ResultJust x) = ResultJust x++instance (Show a) => Show (Result a) where+    showsPrec _ x = (showResult x ++)++showResult (ResultJust l) = show l+showResult rb@ResultBounded {} = sb (resultLB rb) ++ " <= " ++ show (resultRep rb) ++ " <= " ++ sb (resultUB rb)   where+    sb n | null n = "_"+    sb n = show n++++collectVars (Cimplies x y:xs) = x:y:collectVars xs+collectVars [] = []+
+ src/Util/ContextMonad.hs view
@@ -0,0 +1,26 @@+module Util.ContextMonad where++import Control.Monad.Error+import Control.Monad.Identity+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 view
@@ -0,0 +1,39 @@+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 view
@@ -0,0 +1,27 @@++-- | 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 view
@@ -0,0 +1,91 @@+-- | 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 view
@@ -0,0 +1,84 @@+-- | 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 view
@@ -0,0 +1,96 @@+module Util.HasSize where++-- this point of this module is not only to share the 'size' syntax, but to+-- provide optimally lazy versions of size comparasin functions when dealing+-- with lazy structures. This is especially useful when having to compare the+-- size of possibly long lists.++-- it is up to each instance to decide what 'size' means++import qualified Data.Map(Map,size,null)+import qualified Data.Set(Set,size,null)+import qualified Data.IntMap(IntMap,size,null)+import qualified Data.IntSet(IntSet,size,null)+++class IsEmpty a where+    isEmpty :: a -> Bool++class HasSize a where+    size :: a -> Int+    sizeEQ :: Int -> a -> Bool+    sizeGT :: Int -> a -> Bool+    sizeLT :: Int -> a -> Bool+    sizeGTE :: Int -> a -> Bool+    sizeLTE :: Int -> a -> Bool+    sizeEQ s x = size x == s+    sizeGT s x = size x > s+    sizeLT s x = size x < s+    sizeGTE s x = not $ sizeLT s x+    sizeLTE s x = not $ sizeGT s x++genSize :: (Integral b,HasSize a) => a -> b+genSize = fromIntegral . Util.HasSize.size++instance HasSize [x] where+    size = length+    sizeEQ n _ | n < 0 = False+    sizeEQ n xs = f n xs where+        f 0 [] = True+        f _ [] = False+        f 0 _ = False+        f n (_:xs) = sizeEQ (n - 1) xs+    sizeGT n _ | n < 0 = True+    sizeGT n xs = f n xs where+        f 0 (_:_) = True+        f n [] = False+        f n (_:xs) = f (n - 1) xs+    sizeLT n _ | n <= 0 = False+    sizeLT n xs = f n xs where+        f 0 _ = False+        f _ [] = True+        f n (_:xs) = f (n - 1) xs+++instance HasSize (Data.Map.Map a b) where+    size = Data.Map.size+instance HasSize (Data.Set.Set a) where+    size = Data.Set.size+instance HasSize (Data.IntMap.IntMap v) where+    size = Data.IntMap.size+instance HasSize Data.IntSet.IntSet where+    size = Data.IntSet.size++instance (HasSize a,HasSize b) => HasSize (Either a b) where+    size (Left x) = size x+    size (Right y) = size y+    sizeEQ s (Left x)  = sizeEQ s x+    sizeEQ s (Right x)  = sizeEQ s x+    sizeLT s (Left x)  = sizeLT s x+    sizeLT s (Right x)  = sizeLT s x+    sizeGT s (Left x)  = sizeGT s x+    sizeGT s (Right x)  = sizeGT s x++instance (HasSize a,HasSize b) => HasSize (a,b) where+    size (x,y) = size x + size y+instance (HasSize a,HasSize b,HasSize c) => HasSize (a,b,c) where+    size (x,y,z) = size x + size y  + size z++instance IsEmpty [x] where+    isEmpty = null++instance IsEmpty (Data.Map.Map a b) where+    isEmpty = Data.Map.null+instance IsEmpty (Data.Set.Set a) where+    isEmpty = Data.Set.null+instance IsEmpty (Data.IntMap.IntMap v) where+    isEmpty = Data.IntMap.null+instance IsEmpty Data.IntSet.IntSet where+    isEmpty = Data.IntSet.null++instance (IsEmpty a,IsEmpty b) => IsEmpty (a,b) where+    isEmpty (x,y) = isEmpty x && isEmpty y+instance (IsEmpty a,IsEmpty b,IsEmpty c) => IsEmpty (a,b,c) where+    isEmpty (x,y,z) = isEmpty x && isEmpty y  && isEmpty z++
+ src/Util/Histogram.hs view
@@ -0,0 +1,56 @@+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 view
@@ -0,0 +1,29 @@++-- 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.Foldable  hiding(or)+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 view
@@ -0,0 +1,1335 @@+{-# 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++#if __GLASGOW_HASKELL__ >= 503+import GHC.Word+import GHC.Exts ( Word(..), Int(..), shiftRL# )+#elif __GLASGOW_HASKELL__+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#else+import Data.Word+#endif++--infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++natFromInt :: Key -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Key+intFromNat w = fromIntegral w++shiftRL :: Nat -> Key -> Nat+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+  GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i)+  = W# (shiftRL# x i)+#else+shiftRL x i   = shiftR x i+#endif++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | /O(min(n,W))/. Find the value at a key.+-- Calls 'error' when the element can not be found.++(!) :: IntBag-> Key -> Int+m ! k    = find' k m++-- | /O(n+m)/. See 'difference'.+--(\\) :: IntBag -> IntBag -> IntBag+--m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+-- | A map of integers to values @a@.+data IntBag = Nil+              | Tip {-# UNPACK #-} !Key {-# UNPACK #-} !Int+              | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntBag !IntBag++type Prefix = Int+type Mask   = Int+type Key    = Int++instance Monoid IntBag where+    mempty  = empty+    mappend = union+    mconcat = unions++++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+null :: IntBag -> Bool+null Nil   = True+null other = False++-- | /O(n)/. Number of elements in the map.+size :: IntBag -> Int+size t+  = case t of+      Bin p m l r -> size l + size r+      Tip k x -> x+      Nil     -> 0++-- | /O(min(n,W))/. Is the key a member of the map?+--member :: Key -> IntBag -> Bool+--member k m+--  = case lookup k m of+--      Nothing -> False+--      Just x  -> True++-- | /O(log n)/. Is the key not a member of the map?+--notMember :: Key -> IntBag -> Bool+--notMember k m = not $ member k m++-- | /O(min(n,W))/. Lookup the value at a key in the map.+--lookup :: (Monad m) => Key -> IntBag -> m Int+--lookup k t = case lookup' k t of+--    Just x -> return x+--    Nothing -> fail "Data.IntBag.lookup: Key not found"+--+--lookup' :: Key -> IntBag -> Maybe Int+--lookup' k t+--  = let nk = natFromInt k  in seq nk (lookupN nk t)+--+--+lookupN :: Nat -> IntBag -> Int+lookupN k t+  = case t of+      Bin p m l r+        | zeroN k (natFromInt m) -> lookupN k l+        | otherwise              -> lookupN k r+      Tip kx x+        | (k == natFromInt kx)  -> x+        | otherwise             -> 0+      Nil -> 0++find' :: Key -> IntBag -> Int+find' k m  = lookupN (natFromInt k) m+++-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--findWithDefault :: Int -> Key -> IntBag -> Int+--findWithDefault def k m+--  = case lookup k m of+--      Nothing -> def+--      Just x  -> x++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+empty :: IntBag+empty = Nil++-- | /O(1)/. A map of one element.+singleton :: Key -> IntBag+singleton k = Tip k 1++msingleton :: Key -> Int -> IntBag+msingleton k x | x > 0 = Tip k x+               | otherwise = Nil++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- added to the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: Key -> Int -> IntBag -> IntBag+insert k x t | k `seq` x < 0 = delete k (negate x) t+insert _ 0 t = t+insert k x t = f t where+    f t = case t of+      Bin p m l r+        | nomatch k p m -> join k (Tip k x) p t+        | zero k m      -> Bin p m (f l) r+        | otherwise     -> Bin p m l (f r)+      Tip ky y+        | k==ky         -> Tip k (x + y)+        | otherwise     -> join k (Tip k x) ky t+      Nil -> Tip k x++++{--------------------------------------------------------------------+  Deletion+  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: Key -> Int -> IntBag -> IntBag+delete k 0 t | k `seq` True = t+delete k x t | x < 0 = insert k (negate x) t+delete k x t = f t where+    f t = case t of+      Bin p m l r+        | nomatch k p m -> t+        | zero k m      -> bin p m (f l) r+        | otherwise     -> bin p m l (f r)+      Tip ky y+        | k==ky         -> if y < x then Nil else Tip ky (y - x)+        | otherwise     -> t+      Nil -> Nil++---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+---- a member of the map, the original map is returned.+--adjust ::  (a -> a) -> Key -> IntBag -> IntBag+--adjust f k m+--  = adjustWithKey (\k x -> f x) k m+--+---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+---- a member of the map, the original map is returned.+--adjustWithKey ::  (Key -> a -> a) -> Key -> IntBag -> IntBag+--adjustWithKey f k m+--  = updateWithKey (\k x -> Just (f k x)) k m+--+---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+---- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+---- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--update ::  (a -> Maybe a) -> Key -> IntBag -> IntBag+--update f k m+--  = updateWithKey (\k x -> f x) k m+--+---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+---- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+---- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntBag -> IntBag+--updateWithKey f k t+--  = case t of+--      Bin p m l r+--        | nomatch k p m -> t+--        | zero k m      -> bin p m (updateWithKey f k l) r+--        | otherwise     -> bin p m l (updateWithKey f k r)+--      Tip ky y+--        | k==ky         -> case (f k y) of+--                             Just y' -> Tip ky y'+--                             Nothing -> Nil+--        | otherwise     -> t+--      Nil -> Nil+--+---- | /O(min(n,W))/. Lookup and update.+--updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntBag -> (Maybe a,IntBag)+--updateLookupWithKey f k t+--  = case t of+--      Bin p m l r+--        | nomatch k p m -> (Nothing,t)+--        | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)+--        | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')+--      Tip ky y+--        | k==ky         -> case (f k y) of+--                             Just y' -> (Just y,Tip ky y')+--                             Nothing -> (Just y,Nil)+--        | otherwise     -> (Nothing,t)+--      Nil -> (Nothing,Nil)+--+--+--+---- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+---- 'alter' can be used to insert, delete, or update a value in a 'Map'.+---- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@+--alter f k t+--  = case t of+--      Bin p m l r+--        | nomatch k p m -> case f Nothing of+--                             Nothing -> t+--                             Just x -> join k (Tip k x) p t+--        | zero k m      -> bin p m (alter f k l) r+--        | otherwise     -> bin p m l (alter f k r)+--      Tip ky y+--        | k==ky         -> case f (Just y) of+--                             Just x -> Tip ky x+--                             Nothing -> Nil+--        | otherwise     -> case f Nothing of+--                             Just x -> join k (Tip k x) ky t+--                             Nothing -> Tip ky y+--      Nil               -> case f Nothing of+--                             Just x -> Tip k x+--                             Nothing -> Nil+--++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+unions :: [IntBag] -> IntBag+unions xs+  = foldlStrict union empty xs++-- | The union of a list of maps, with a combining operation+--unionsWith :: (Int->Int->Int) -> [IntBag] -> IntBag+--unionsWith f ts+--  = foldlStrict (unionWith f) empty ts++-- | /O(n+m)/. The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+union :: IntBag -> IntBag -> IntBag+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (union t1 r2)++union (Tip k x) t = insert k x t+union t (Tip k x) = insert k x t+--union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias+union Nil t       = t+union t Nil       = t++-- | /O(n+m)/. The union with a combining function.+--unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+--unionWith f m1 m2+--  = unionWithKey (\k x y -> f x y) m1 m2+--+---- | /O(n+m)/. The union with a combining function.+--unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+--unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = union1+--  | shorter m2 m1  = union2+--  | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)+--  | otherwise      = join p1 t1 p2 t2+--  where+--    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+--            | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1+--            | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)+--+--    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+--            | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2+--            | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)+--+--unionWithKey f (Tip k x) t = insertWithKey f k x t+--unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias+--unionWithKey f Nil t  = t+--unionWithKey f t Nil  = t++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two maps (based on keys).+--difference :: IntMap a -> IntMap b -> IntMap a+--difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = difference1+--  | shorter m2 m1  = difference2+--  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)+--  | otherwise      = t1+--  where+--    difference1 | nomatch p2 p1 m1  = t1+--                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1+--                | otherwise         = bin p1 m1 l1 (difference r1 t2)+--+--    difference2 | nomatch p1 p2 m2  = t1+--                | zero p1 m2        = difference t1 l2+--                | otherwise         = difference t1 r2+--+--difference t1@(Tip k x) t2+--  | member k t2  = Nil+--  | otherwise    = t1+--+--difference Nil t       = Nil+--difference t (Tip k x) = delete k t+--difference t Nil       = t+--+---- | /O(n+m)/. Difference with a combining function.+--differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+--differenceWith f m1 m2+--  = differenceWithKey (\k x y -> f x y) m1 m2+--+---- | /O(n+m)/. Difference with a combining function. When two equal keys are+---- encountered, the combining function is applied to the key and both values.+---- If it returns 'Nothing', the element is discarded (proper set difference).+---- If it returns (@'Just' y@), the element is updated with a new value @y@.+--differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+--differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = difference1+--  | shorter m2 m1  = difference2+--  | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)+--  | otherwise      = t1+--  where+--    difference1 | nomatch p2 p1 m1  = t1+--                | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1+--                | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)+--+--    difference2 | nomatch p1 p2 m2  = t1+--                | zero p1 m2        = differenceWithKey f t1 l2+--                | otherwise         = differenceWithKey f t1 r2+--+--differenceWithKey f t1@(Tip k x) t2+--  = case lookup k t2 of+--      Just y  -> case f k x y of+--                   Just y' -> Tip k y'+--                   Nothing -> Nil+--      Nothing -> t1+--+--differenceWithKey f Nil t       = Nil+--differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t+--differenceWithKey f t Nil       = t+--++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+---- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).+--intersection :: IntBag -> IntBag -> IntBag+--intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = intersection1+--  | shorter m2 m1  = intersection2+--  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+--  | otherwise      = Nil+--  where+--    intersection1 | nomatch p2 p1 m1  = Nil+--                  | zero p2 m1        = intersection l1 t2+--                  | otherwise         = intersection r1 t2+--+--    intersection2 | nomatch p1 p2 m2  = Nil+--                  | zero p1 m2        = intersection t1 l2+--                  | otherwise         = intersection t1 r2+--+--intersection t1@(Tip k x) t2+--  | member k t2  = t1+--  | otherwise    = Nil+--intersection t (Tip k x)+--  = case lookup k t of+--      Just y  -> Tip k y+--      Nothing -> Nil+--intersection Nil t = Nil+--intersection t Nil = Nil+--+---- | /O(n+m)/. The intersection with a combining function.+--intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a+--intersectionWith f m1 m2+--  = intersectionWithKey (\k x y -> f x y) m1 m2+--+---- | /O(n+m)/. The intersection with a combining function.+--intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a+--intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = intersection1+--  | shorter m2 m1  = intersection2+--  | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)+--  | otherwise      = Nil+--  where+--    intersection1 | nomatch p2 p1 m1  = Nil+--                  | zero p2 m1        = intersectionWithKey f l1 t2+--                  | otherwise         = intersectionWithKey f r1 t2+--+--    intersection2 | nomatch p1 p2 m2  = Nil+--                  | zero p1 m2        = intersectionWithKey f t1 l2+--                  | otherwise         = intersectionWithKey f t1 r2+--+--intersectionWithKey f t1@(Tip k x) t2+--  = case lookup k t2 of+--      Just y  -> Tip k (f k x y)+--      Nothing -> Nil+--intersectionWithKey f t1 (Tip k y)+--  = case lookup k t1 of+--      Just x  -> Tip k (f k x y)+--      Nothing -> Nil+--intersectionWithKey f Nil t = Nil+--intersectionWithKey f t Nil = Nil+++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+--isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+--isProperSubmapOf m1 m2+--  = isProperSubmapOfBy (==) m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+--isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+--isProperSubmapOfBy pred t1 t2+--  = case submapCmp pred t1 t2 of+--      LT -> True+--      ge -> False+--+--submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+--  | shorter m1 m2  = GT+--  | shorter m2 m1  = submapCmpLt+--  | p1 == p2       = submapCmpEq+--  | otherwise      = GT  -- disjoint+--  where+--    submapCmpLt | nomatch p1 p2 m2  = GT+--                | zero p1 m2        = submapCmp pred t1 l2+--                | otherwise         = submapCmp pred t1 r2+--    submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of+--                    (GT,_ ) -> GT+--                    (_ ,GT) -> GT+--                    (EQ,EQ) -> EQ+--                    other   -> LT+--+--submapCmp pred (Bin p m l r) t  = GT+--submapCmp pred (Tip kx x) (Tip ky y)+--  | (kx == ky) && pred x y = EQ+--  | otherwise              = GT  -- disjoint+--submapCmp pred (Tip k x) t+--  = case lookup k t of+--     Just y  | pred x y -> LT+--     other   -> GT -- disjoint+--submapCmp pred Nil Nil = EQ+--submapCmp pred Nil t   = LT+--+---- | /O(n+m)/. Is this a submap?+---- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+--isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+--isSubmapOf m1 m2+--  = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+{-++isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2+                                                      else isSubmapOfBy pred t1 r2)+  | otherwise      = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2+isSubmapOfBy pred (Bin p m l r) t  = False+isSubmapOfBy pred (Tip k x) t      = case lookup k t of+                                   Just y  -> pred x y+                                   Nothing -> False+isSubmapOfBy pred Nil t            = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntMap a -> IntMap b+map f m+  = mapWithKey (\k x -> f x) m++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k (f k x)+      Nil         -> Nil++-- | /O(n)/. The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f a m+  = mapAccumWithKey (\a k x -> f a x) a m++-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+  = case t of+      Bin p m l r -> let (a1,l') = mapAccumL f a l+                         (a2,r') = mapAccumL f a1 r+                     in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)+++-- | /O(n)/. The function @'mapAccumR'@ threads an accumulating+-- argument throught the map in descending order of keys.+mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumR f a t+  = case t of+      Bin p m l r -> let (a1,r') = mapAccumR f a r+                         (a2,l') = mapAccumR f a1 l+                     in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy some predicate.+filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+  = filterWithKey (\k x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy some predicate.+filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey pred t+  = case t of+      Bin p m l r+        -> bin p m (filterWithKey pred l) (filterWithKey pred r)+      Tip k x+        | pred k x  -> t+        | otherwise -> Nil+      Nil -> Nil++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+  = partitionWithKey (\k x -> p x) m++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey pred t+  = case t of+      Bin p m l r+        -> let (l1,l2) = partitionWithKey pred l+               (r1,r2) = partitionWithKey pred r+           in (bin p m l1 r1, bin p m l2 r2)+      Tip k x+        | pred k x  -> (t,Nil)+        | otherwise -> (Nil,t)+      Nil -> (Nil,Nil)++-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f m+  = mapMaybeWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey f Nil = Nil++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f (Bin p m l r)+  = (bin p m l1 r1, bin p m l2 r2)+  where+    (l1,l2) = mapEitherWithKey f l+    (r1,r2) = mapEitherWithKey f r+mapEitherWithKey f (Tip k x) = case f k x of+  Left y  -> (Tip k y, Nil)+  Right z -> (Nil, Tip k z)+mapEitherWithKey f Nil = (Nil, Nil)++-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+split :: Key -> IntMap a -> (IntMap a,IntMap a)+split k t+  = case t of+      Bin p m l r+          | m < 0 -> (if k >= 0 -- handle negative numbers.+                      then let (lt,gt) = split' k l in (union r lt, gt)+                      else let (lt,gt) = split' k r in (lt, union gt l))+          | otherwise   -> split' k t+      Tip ky y+        | k>ky      -> (t,Nil)+        | k<ky      -> (Nil,t)+        | otherwise -> (Nil,Nil)+      Nil -> (Nil,Nil)++split' :: Key -> IntMap a -> (IntMap a,IntMap a)+split' k t+  = case t of+      Bin p m l r+        | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)+        | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)+        | otherwise -> let (lt,gt) = split k r in (union l lt,gt)+      Tip ky y+        | k>ky      -> (t,Nil)+        | k<ky      -> (Nil,t)+        | otherwise -> (Nil,Nil)+      Nil -> (Nil,Nil)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup k t+  = case t of+      Bin p m l r+          | m < 0 -> (if k >= 0 -- handle negative numbers.+                      then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)+                      else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))+          | otherwise   -> splitLookup' k t+      Tip ky y+        | k>ky      -> (t,Nothing,Nil)+        | k<ky      -> (Nil,Nothing,t)+        | otherwise -> (Nil,Just y,Nil)+      Nil -> (Nil,Nothing,Nil)++splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup' k t+  = case t of+      Bin p m l r+        | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)+        | zero k m  -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)+        | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)+      Tip ky y+        | k>ky      -> (t,Nothing,Nil)+        | k<ky      -> (Nil,Nothing,t)+        | otherwise -> (Nil,Just y,Nil)+      Nil -> (Nil,Nothing,Nil)+      -}++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+fold :: (Int -> b -> b) -> b -> IntBag -> b+fold f z t+  = foldWithKey (\k x y -> f x y) z t++-- | /O(n)/. Fold the keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+-- For example,+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+--+foldWithKey :: (Key -> Int -> b -> b) -> b -> IntBag -> b+foldWithKey f z t+  = foldr f z t++foldr :: (Key -> Int -> b -> b) -> b -> IntBag -> b+foldr f z t+  = case t of+      Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r  -- put negative numbers before.+      Bin _ _ _ _ -> foldr' f z t+      Tip k x     -> f k x z+      Nil         -> z++foldr' :: (Key -> Int -> b -> b) -> b -> IntBag -> b+foldr' f z t+  = case t of+      Bin p m l r -> foldr' f (foldr' f z r) l+      Tip k x     -> f k x z+      Nil         -> z++++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+--elems :: IntMap a -> [a]+--elems m+--  = foldWithKey (\k x xs -> x:xs) [] m+--+---- | /O(n)/. Return all keys of the map in ascending order.+--keys  :: IntMap a -> [Key]+--keys m+--  = foldWithKey (\k x ks -> k:ks) [] m+--+---- | /O(n*min(n,W))/. The set of all keys of the map.+--keysSet :: IntMap a -> IntSet.IntSet+--keysSet m = IntSet.fromDistinctAscList (keys m)+++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+assocs :: IntBag -> [(Key,Int)]+assocs m = toList m+++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | /O(n)/. Convert the map to a list of key\/value pairs.+toList :: IntBag -> [(Key,Int)]+toList t+  = foldWithKey (\k x xs -> (k,x):xs) [] t++-- | /O(n)/. Convert the map to a list of key\/value pairs where the+-- keys are in ascending order.+toAscList :: IntBag -> [(Key,Int)]+toAscList t+  = -- NOTE: the following algorithm only works for big-endian trees+    let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+fromList :: [(Key,Int)] -> IntBag+fromList xs+  = foldlStrict ins empty xs+  where+    ins t (k,x)  = insert k x t+--+---- | /O(n*min(n,W))/.  Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+--fromListWith f xs+--  = fromListWithKey (\k x y -> f x y) xs+--+---- | /O(n*min(n,W))/.  Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+--fromListWithKey f xs+--  = foldlStrict ins empty xs+--  where+--    ins t (k,x) = insertWithKey f k x t+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order.+--fromAscList :: [(Key,a)] -> IntMap a+--fromAscList xs+--  = fromList xs+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order, with a combining function on equal keys.+--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+--fromAscListWith f xs+--  = fromListWith f xs+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order, with a combining function on equal keys.+--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+--fromAscListWithKey f xs+--  = fromListWithKey f xs+--+---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+---- the keys are in ascending order and all distinct.+--fromDistinctAscList :: [(Key,a)] -> IntMap a+--fromDistinctAscList xs+--  = fromList xs+++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq IntBag where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: IntBag -> IntBag -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal t1 t2   = False++nequal :: IntBag -> IntBag -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx x) (Tip ky y)+  = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal t1 t2   = True++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord IntBag where+    compare m1 m2 = compare (toList m1) (toList m2)+++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show IntBag where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++--showMap :: (Show a) => [(Key,a)] -> ShowS+--showMap []+--  = showString "{}"+--showMap (x:xs)+--  = showChar '{' . showElem x . showTail xs+--  where+--    showTail []     = showChar '}'+--    showTail (x:xs) = showChar ',' . showElem x . showTail xs+--+--    showElem (k,x)  = shows k . showString ":=" . shows x+--+--{--------------------------------------------------------------------+--  Read+----------------------------------------------------------------------}+--instance (Read e) => Read (IntMap e) where+-- #ifdef __GLASGOW_HASKELL__+--  readPrec = parens $ prec 10 $ do+--    Ident "fromList" <- lexP+--    xs <- readPrec+--    return (fromList xs)+--+--  readListPrec = readListPrecDefault+-- #else+--  readsPrec p = readParen (p > 10) $ \ r -> do+--    ("fromList",s) <- lex r+--    (xs,t) <- reads s+--    return (fromList xs,t)+-- #endif+--+--{--------------------------------------------------------------------+--  Typeable+----------------------------------------------------------------------}+--+-- #include "Typeable.h"+--INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")+--+--{--------------------------------------------------------------------+--  Debugging+----------------------------------------------------------------------}+---- | /O(n)/. Show the tree that implements the map. The tree is shown+---- in a compressed, hanging format.+--showTree :: Show a => IntMap a -> String+--showTree s+--  = showTreeWith True False s+--+--+--{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+-- the tree that implements the map. If @hang@ is+-- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+-- @wide@ is 'True', an extra wide version is shown.+---}+--showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+--showTreeWith hang wide t+--  | hang      = (showsTreeHang wide [] t) ""+--  | otherwise = (showsTree wide [] [] t) ""+--+--showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+--showsTree wide lbars rbars t+--  = case t of+--      Bin p m l r+--          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+--             showWide wide rbars .+--             showsBars lbars . showString (showBin p m) . showString "\n" .+--             showWide wide lbars .+--             showsTree wide (withEmpty lbars) (withBar lbars) l+--      Tip k x+--          -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"+--      Nil -> showsBars lbars . showString "|\n"+--+--showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+--showsTreeHang wide bars t+--  = case t of+--      Bin p m l r+--          -> showsBars bars . showString (showBin p m) . showString "\n" .+--             showWide wide bars .+--             showsTreeHang wide (withBar bars) l .+--             showWide wide bars .+--             showsTreeHang wide (withEmpty bars) r+--      Tip k x+--          -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"+--      Nil -> showsBars bars . showString "|\n"+--+--showBin p m+--  = "*" -- ++ show (p,m)+--+--showWide wide bars+--  | wide      = showString (concat (reverse bars)) . showString "|\n"+--  | otherwise = id+--+--showsBars :: [String] -> ShowS+--showsBars bars+--  = case bars of+--      [] -> id+--      _  -> showString (concat (reverse (tail bars))) . showString node+--+--node           = "+--"+--withBar bars   = "|  ":bars+--withEmpty bars = "   ":bars+--+--+{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Join+--------------------------------------------------------------------}+join :: Prefix -> IntBag -> Prefix -> IntBag -> IntBag+join p1 t1 p2 t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    m = branchMask p1 p2+    p = mask p1 m++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntBag -> IntBag -> IntBag+bin p m l Nil = l+bin p m Nil r = r+bin p m l r   = Bin p m l r+++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p++match i p m+  = (mask i m) == p++mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))++{----------------------------------------------------------------------+  Finding the highest bit (mask) in a word [x] can be done efficiently in+  three ways:+  * convert to a floating point value and the mantissa tells us the+    [log2(x)] that corresponds with the highest bit position. The mantissa+    is retrieved either via the standard C function [frexp] or by some bit+    twiddling on IEEE compatible numbers (float). Note that one needs to+    use at least [double] precision for an accurate mantissa of 32 bit+    numbers.+  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+  * use processor specific assembler instruction (asm).++  The most portable way would be [bit], but is it efficient enough?+  I have measured the cycle counts of the different methods on an AMD+  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++  highestBitMask: method  cycles+                  --------------+                   frexp   200+                   float    33+                   bit      11+                   asm      12++  highestBit:     method  cycles+                  --------------+                   frexp   195+                   float    33+                   bit      11+                   asm      11++  Wow, the bit twiddling is on today's RISC like machines even faster+  than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+  [highestBitMask] returns a word where only the highest bit is set.+  It is found by first setting all bits in lower positions than the+  highest bit and than taking an exclusive or with the original value.+  Allthough the function may look expensive, GHC compiles this into+  excellent C code that subsequently compiled into highly efficient+  machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x+  = case (x .|. shiftRL x 1) of+     x -> case (x .|. shiftRL x 2) of+      x -> case (x .|. shiftRL x 4) of+       x -> case (x .|. shiftRL x 8) of+        x -> case (x .|. shiftRL x 16) of+         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms+          x -> (x `xor` (shiftRL x 1))+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree :: [Int] -> IntMap Int+testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (IntMap a) where+  arbitrary = do{ ks <- arbitrary+                ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks+                ; return (fromList xs)+                }+++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Key -> Int -> Bool+prop_Single k x+  = (insert k x empty == singleton k x)++prop_InsertDelete :: Key -> Int -> IntMap Int -> Property+prop_InsertDelete k x t+  = not (member k t) ==> delete k (insert k x t) == t++prop_UpdateDelete :: Key -> IntMap Int -> Bool+prop_UpdateDelete k t+  = update (const Nothing) k t == delete k t+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool+prop_UnionInsert k x t+  = union (singleton k x) t == insert k x t++prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: IntMap Int -> IntMap Int -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == unionWith (\x y -> y) t2 t1)+++prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Diff xs ys+  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))+    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))++prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Int xs ys+  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))+    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [(x,()) | x <- [0..n::Int]]+    in fromAscList xs == fromList xs++prop_List :: [Key] -> Bool+prop_List xs+  = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])+-}
+ src/Util/Interact.hs view
@@ -0,0 +1,154 @@+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 view
@@ -0,0 +1,89 @@+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++-- | 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 view
@@ -0,0 +1,101 @@++-- | a simple type that only lets an IO action happen once, caching its result.++module Util.Once(+    Once,+    newOnce,+    runOnce,+    altOnce,++    OnceMap,+    newOnceMap,+    runOnceMap,+    altOnceMap,+    onceMapToList,+    onceMapKeys,+    onceMapElems++    ) where++import qualified Data.Map as Map+import Data.IORef+import Data.Dynamic++newtype Once a = Once (IORef (Maybe a))+    deriving(Typeable)+++-- | create a new Once object+newOnce :: IO (Once a)+newOnce = do+    ref <- newIORef Nothing+    return (Once ref)++-- | execute the action at most once, always returning the same result+runOnce :: Once a -> IO a -> IO a+runOnce (Once ref) action = do+    b <- readIORef ref+    case b of+        Just x -> return x+        Nothing -> do+            r <- action+            writeIORef ref (Just r)+            return r++-- | run first argument once, after which perform the second++altOnce :: Once () -> IO b -> IO b -> IO b+altOnce (Once ref) first second = do+    b <- readIORef ref+    case b of+        Just _ -> second+        Nothing -> do+            writeIORef ref (Just ())+            first+++-- | run an IO action at most once for each distinct argument++newtype OnceMap a b = OnceMap (IORef (Map.Map a b))+    deriving(Typeable)+++newOnceMap :: Ord a => IO (OnceMap a b)+newOnceMap = do+    r <- newIORef Map.empty+    return $ OnceMap r++runOnceMap :: Ord a => OnceMap a b -> a -> IO b -> IO b+runOnceMap (OnceMap r) x act = do+    m <- readIORef r+    case Map.lookup x m of+        Just y -> return y+        Nothing -> do+            y <- act+            modifyIORef r (Map.insert x y)+            return y++altOnceMap :: Ord a => OnceMap a () -> a -> IO b -> IO b -> IO b+altOnceMap (OnceMap ref) x first after = do+    m <- readIORef ref+    case Map.member x m of+        True -> after+        False -> do+            modifyIORef ref (Map.insert x ())+            first++onceMapToList :: OnceMap a b -> IO [(a,b)]+onceMapToList (OnceMap ref) = do+    m <- readIORef ref+    return $ Map.toList m++onceMapKeys :: OnceMap a b -> IO [a]+onceMapKeys (OnceMap ref) = do+    m <- readIORef ref+    return $ Map.keys m++onceMapElems :: OnceMap a b -> IO [b]+onceMapElems (OnceMap ref) = do+    m <- readIORef ref+    return $ Map.elems m+
+ src/Util/Perhaps.hs view
@@ -0,0 +1,19 @@+module Util.Perhaps where++import Data.Typeable+import Data.Monoid++data Perhaps = No | Maybe | Yes+    deriving(Show,Read,Typeable,Eq,Ord)+++-- the greatest lower bound was chosen as the Monoid+-- the least upper bound is just the maximum under Ord+instance Monoid Perhaps where+    mempty = No+    Yes `mappend` Yes = Yes+    No  `mappend` No  = No+    _   `mappend` _   = Maybe+++
+ src/Util/RWS.hs view
@@ -0,0 +1,150 @@+{-# 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+import Control.Monad.Fix+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.Writer+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 view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module Util.ReaderWriter(ReaderWriter(),runReaderWriter) where++import Data.Monoid+import Control.Monad.Reader+import Control.Monad.Writer+-- strict unboxed ReaderWriter monad+++newtype ReaderWriter r w a = ReaderWriter { _runReaderWriter :: r -> (# a, w #) }+++runReaderWriter :: ReaderWriter r w a -> r -> (a,w)+runReaderWriter (ReaderWriter m) r = case m r of+    (# a, w #) -> (a,w)++instance Functor (ReaderWriter r w) where+	fmap f (ReaderWriter g) = ReaderWriter $ \r -> case g r of+            (# a, w #) -> (# f a, w #)++instance (Monoid w) => Monad (ReaderWriter r w) where+	return a = ReaderWriter $ \_ -> (# a, mempty #)+	(ReaderWriter m) >>= k  = ReaderWriter $ \r -> case m r of+            (# a,w #) -> case k a of+                ReaderWriter g -> case g r of+                    (# b, w' #) -> let w'' = w `mappend` w' in w'' `seq` (# b, w'' #)+        (ReaderWriter f) >> (ReaderWriter g) = ReaderWriter $ \r -> case f r of+            (# _, w #) -> case g r of+                (# a, w' #) -> let w'' = w `mappend` w' in w'' `seq` (# a, w'' #)+++instance (Monoid w) => MonadWriter w (ReaderWriter r w) where+	tell   w = ReaderWriter $ \ _ -> w `seq` (# (), w #)+	listen (ReaderWriter m) = ReaderWriter $ \r -> case m r of+            (# a , w #) -> (# (a,w), w #)+	pass  (ReaderWriter m) = ReaderWriter $ \r -> case m r of+           (# (a, f), w #) -> let w' = f w in w' `seq` (# a, w' #)++instance Monoid w => MonadReader r (ReaderWriter r w) where+	ask       = ReaderWriter $ \r -> (# r, mempty #)+	local f (ReaderWriter m) = ReaderWriter $ \r -> m (f r)++
+ src/Util/Relation.hs view
@@ -0,0 +1,42 @@++-- | 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 view
@@ -0,0 +1,45 @@+module Util.SameShape where++import Data.Tree++++--class SameShape a b where+--    sameShape :: a -> b -> Bool++--instance (SameShape1 f) => SameShape (f a) (f b) where+--    sameShape x y = sameShape1 x y+--instance (SameShape2 f) => SameShape (f a b) (f c d) where+--    sameShape x y = sameShape2 x y++class SameShape1 f where+    sameShape1 :: f a -> f b -> Bool+class SameShape2 f where+    sameShape2 :: f a b -> f c d -> Bool+++instance SameShape1 [] where+    sameShape1 [] [] = True+    sameShape1 (_:xs) (_:ys) = sameShape1 xs ys+    sameShape1 _ _ = False++instance SameShape1 Tree where+    sameShape1 (Node _ xs) (Node _ ys) = f xs ys where+        f [] [] = True+        f (x:xs) (y:ys) = sameShape1 x y && f xs ys+        f _ _ = False++instance SameShape1 Maybe where+    sameShape1 (Just _) (Just _) = True+    sameShape1 Nothing Nothing = True+    sameShape1 _ _ = False++instance SameShape2 Either where+    sameShape2 (Left _) (Left _) = True+    sameShape2 (Right _) (Right _) = True+    sameShape2 _ _ = False++instance SameShape1 IO where+    sameShape1 _ _ = True++
+ src/Util/Seq.hs view
@@ -0,0 +1,124 @@+--------------------------------------------------------------------------------+{-| 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 view
@@ -0,0 +1,213 @@+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/TrueSet.hs view
@@ -0,0 +1,60 @@+module Util.TrueSet(+    TrueSet,+    fromList,+    member,+    empty,+    full,+    singleton,+    insert,+    delete,+    unions,+    union,+    intersection,+    intersects,+    difference,+    (\\)+    ) where++import qualified Data.Set as Set++infixl 9 \\+++data TrueSet a = TrueSet (Set.Set a) Bool++False `xor` y = y+True `xor` y = not y++fromList xs = TrueSet (Set.fromList xs) False+member x (TrueSet s inv) = inv `xor` (Set.member x s)++invert (TrueSet x y) = TrueSet x (not y)+empty = TrueSet Set.empty False+full = TrueSet Set.empty False+singleton x = TrueSet (Set.singleton x) False+insert x (TrueSet s False) = TrueSet (Set.insert x s) False+insert x (TrueSet s True) = TrueSet (Set.delete x s) True+delete x (TrueSet s False) = TrueSet (Set.delete x s) False+delete x (TrueSet s True) = TrueSet (Set.insert x s) True++unions xs = foldlStrict union empty xs+intersects xs = foldlStrict intersection full xs++foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)++difference x y = x `intersection` invert y+m1 \\ m2 = difference m1 m2++(TrueSet x True)  `intersection` (TrueSet y True) = TrueSet (x `Set.union` y) True+(TrueSet x False) `intersection` (TrueSet y False) = TrueSet (x `Set.intersection` y) False+(TrueSet x True)  `intersection` (TrueSet y False) = TrueSet (y Set.\\ x) False+(TrueSet x False) `intersection` (TrueSet y True) = TrueSet (x Set.\\ y) False+(TrueSet x True)  `union` (TrueSet y True) = TrueSet (x `Set.intersection` y) True+(TrueSet x False) `union` (TrueSet y False) = TrueSet (x `Set.union` y) False+(TrueSet x True)  `union` (TrueSet y False) = TrueSet (x Set.\\ y) True+(TrueSet x False) `union` (TrueSet y True) = TrueSet (y Set.\\ x) True++
+ src/Util/UnionFind.hs view
@@ -0,0 +1,96 @@+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 view
@@ -0,0 +1,353 @@+module Util.UnionSolve(+    C(),+    solve,+    Fixable(..),+    Topped(..),+    Result(..),+    islte,isgte,equals+    ) where++import Control.Monad(when)+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 view
@@ -0,0 +1,54 @@+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+++instance UniqueProducer IO where+    newUniq = do+        u <- newUnique+        return $ hashUnique u++instance Monad m =>  UniqueProducer (UniqT m) where+    newUniq = UniqT $ do+        modify (+1)+        get++-- | Run the transformer version of the unique int generator.+runUniqT :: Monad m =>  UniqT m a -> Int -> m (a,Int)+runUniqT (UniqT sm) s  = runStateT sm s++-- | Run the bare version of the unique int generator.+runUniq :: Int -> Uniq a -> (a,Int)+runUniq x y = runIdentity $ runUniqT y x++-- | Execute the bare unique int generator starting with 1.+execUniq1 :: Uniq a -> a+execUniq1 x = fst $ runUniq 1 x++-- | Execute the bare unique int generator starting with the suplied number.+execUniq :: Int -> Uniq a -> a+execUniq st x = fst $ runUniq st x++-- | Execute the transformer version of the unique int generator starting with the suplied number.+execUniqT :: Monad m =>  Int -> UniqT m a -> m a+execUniqT s (UniqT sm)  = liftM fst $ runStateT sm s++instance (Monad m, Monad (t m), MonadTrans t, UniqueProducer m) => UniqueProducer (t m) where+    newUniq = lift newUniq++-- | Unique integer generator monad transformer.+newtype UniqT m a = UniqT (StateT Int m a)+    deriving(Monad,  MonadTrans, Functor, MonadFix, MonadPlus)++instance MonadReader s m => MonadReader s (UniqT m) where+    ask = UniqT $  ask+    local f (UniqT x) = UniqT $ local f x++-- | Unique integer generator monad.+type Uniq = UniqT Identity
+ src/Util/Util.hs view
@@ -0,0 +1,11 @@+module Util.Util(+    module Data.Monoid,+    module Data.List,+    module Data.Maybe,+    module Control.Monad+    ) where++import Data.Monoid+import Data.Maybe+import Data.List+import Control.Monad
+ src/Util/VarName.hs view
@@ -0,0 +1,72 @@+module Util.VarName(+    VarNameT(),+    VarName(),+    runVarNameT,+    runVarName,+    newName,+    subVarName,+    lookupName,+    maybeLookupName,+    newLookupName) where++import Control.Monad.State+import Control.Monad.Identity+import qualified Data.Map as Map++newtype VarNameT nc ni no m a = VarName (StateT (Map.Map ni no, Map.Map nc Int) m a)+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)++type VarName ni no a = VarNameT () ni no Identity a+++runVarNameT :: Monad m => VarNameT nc ni no m a -> m a+runVarNameT  (VarName sm) = evalStateT sm (Map.empty, Map.empty)++runVarName ::  VarName ni no a -> a+runVarName v = runIdentity $ runVarNameT v++subVarName ::  Monad m => VarNameT nc ni no m a -> VarNameT nc ni no m a+subVarName (VarName action) = VarName $ do+    x <- get+    r <- action+    put x+    return r+++newName :: (Ord ni, Ord nc,Monad m) => [no] -> nc -> ni -> VarNameT nc ni no m no+newName ns nc ni = VarName $ do+    (nim,ncm) <- get+    let no = ns!!i+        Just i = fmap (subtract 1) $ Map.lookup nc ncm'+        ncm' = Map.insertWith (+) nc 1 ncm+    put (Map.insert ni no nim, ncm')+    return no++lookupName :: (Ord ni, Monad m,Show ni) => ni -> VarNameT nc ni no m no+lookupName t = VarName $ do+    (nim,_) <- get+    case Map.lookup t nim of+        Just x -> return x+        Nothing -> fail $ "lookupName not found: " ++ show t++maybeLookupName :: (Ord ni, Monad m,Show ni) => ni -> VarNameT nc ni no m (Maybe no)+maybeLookupName t = VarName $ do+    (nim,_) <- get+    case Map.lookup t nim of+        Just x -> return (Just x)+        Nothing -> return $ fail $ "lookupName not found: " ++ show t++newLookupName :: (Ord ni, Ord nc,Monad m) => [no] -> nc -> ni -> VarNameT nc ni no m no+newLookupName ns nc ni = VarName $ do+    (nim,ncm) <- get+    case Map.lookup ni nim of+        Just x -> return x+        Nothing -> do+            let no = ns!!i+                Just i = fmap (subtract 1) $ Map.lookup nc ncm'+                ncm' = Map.insertWith (+) nc 1 ncm+            put (Map.insert ni no nim, ncm')+            return no+++
+ src/arch/generic.arch view
@@ -0,0 +1,75 @@+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 view
@@ -0,0 +1,177 @@+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 view
@@ -0,0 +1,177 @@+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 }+  ]+